Télécharger la plaquette Cast3M


fr en

Télécharger grad1.eso

Retour à la liste

Numérotation des lignes : 

grad1

  1. C GRAD1     SOURCE    MB234859  25/08/04    21:15:10     12339          
  2.  
  3. C=======================================================================
  4. C=                             G R A D 1                               =
  5. C=                             ---------                               =
  6. C=                                                                     =
  7. C=  Fonction :                                                         =
  8. C=  ----------                                                         =
  9. C=  Traitement des informations necessaires au calcul du gradient d'un =
  10. C=  champ deplacement/temperature. Branchement suivant l'element fini. =
  11. C=  Sous-programme appele par GRAD (grad.eso)                          =
  12. C=                                                                     =
  13. C=  Parametres :  (E)=Entree   (S)=Sortie                              =
  14. C=  ------------                                                       =
  15. C=   IPMODL   (E)   Pointeur sur segment MMODEL                        =
  16. C=   IPCHE2   (E)   Pointeur sur segment MCHELM de DEPLACEMENT/TEMPER. =
  17. C=   IPCHE1   (E)   Pointeur sur segment MCHELM de CARACTERISTIQUES    =
  18. C=   IPCHL1   (S)   Pointeur sur segment MCHELM de GRADIENT resultat   =
  19. C=   IRET     (S)   Entier valant 1 en cas de succes, 0 sinon (et un   =
  20. C=                  message d'erreur est imprime dans ce cas)          =
  21. C=                                                                     =
  22. C=  Remarque :  En entree du sousprogramme, IPCHL1 contient le CHPOINT =
  23. C=  ----------  de deplacement ou de temperature fourni a l'operateur  =
  24. C=              'GRAD'. Dans le cas d'un modele MECANIQUE, ce CHPOINT  =
  25. C=              est indispensable a avoir pour calculer les deforma-   =
  26. C=              generalisees au(x) point(s) support(s).                =
  27. C=                                                                     =
  28. C=  Christian LE BRETON - Denis ROBERT-MOUGIN, le 31 juillet 1986.     =
  29. C=  Modifications aux nouvelles normes I.MONNIER, le 28 mai 1990.      =
  30. C=======================================================================
  31.  
  32.       SUBROUTINE GRAD1(IPMODL,MODEPL,IPCHE2,IPCHE1, IPCHL1,IRET)
  33.  
  34.       IMPLICIT INTEGER(I-N)
  35.       IMPLICIT REAL*8 (A-H,O-Z)
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC CCHAMP
  40. -INC CCREEL
  41. C==DEB= FORMULATION HHO == INCLUDE =====================================
  42. -INC CCHHOPA
  43. C==FIN= FORMULATION HHO ================================================
  44.  
  45. -INC SMCHAML
  46. -INC SMMODEL
  47. -INC SMELEME
  48. -INC SMINTE
  49. -INC SMCOORD
  50. -INC SMLREEL
  51.  
  52. -INC TMPTVAL
  53.  
  54.       SEGMENT INFO
  55.         INTEGER INFELL(JG)
  56.       ENDSEGMENT
  57.  
  58.       SEGMENT NOTYPE
  59.         CHARACTER*16 TYPE(NBTYPE)
  60.       ENDSEGMENT
  61.  
  62.       SEGMENT MVELCH
  63.         REAL*8 VALMAT(NV1)
  64.       ENDSEGMENT
  65.  
  66.       SEGMENT MWRK1
  67.         REAL*8 XDDL(LRE),XE(3,NBNO),GRADI(NGRA)
  68.         REAL*8 DDHOOK(NSTRS,NSTRS),DDHOMU(NSTRS,NSTRS)
  69.       ENDSEGMENT
  70.  
  71.       SEGMENT MWRK2
  72.         REAL*8 SHPWRK(6,NBNO),BGR(NGRA,LRE),BB(2,NGRA)
  73.       ENDSEGMENT
  74.  
  75.       SEGMENT MWRK3
  76.         REAL*8 WORK(LW)
  77.       ENDSEGMENT
  78.  
  79.       SEGMENT MWRK4
  80.         REAL*8 BPSS(3,3),XEL(3,NBNO),XDDLOC(LRE)
  81.       ENDSEGMENT
  82.  
  83.       PARAMETER (NINF=3)
  84.       INTEGER INFOS(NINF)
  85.       CHARACTER*8 CMATE
  86.       CHARACTER*(NCONCH) CONM
  87.  
  88.       DIMENSION A(4,60),BBX(3,60),UDPGE(3),PP(4,4)
  89.       LOGICAL LDPGE,lsupgd,lsupdp
  90.       INTEGER ISUP1
  91.  
  92. C     Booleen de determination automatique des noms de composantes
  93.       LOGICAL COMAUT
  94.  
  95.       IF(MODEPL.GT.0) THEN
  96.         COMAUT=.FALSE.
  97.       ELSE
  98.         COMAUT=.TRUE.
  99.       ENDIF
  100.  
  101.       IRET=0
  102.       ISUP1=0
  103.       iMess=0
  104.  
  105. C  1 - QUELQUES INITIALISATIONS
  106. C ==============================
  107. C  1.1 - Analyse du MMODEL
  108. C =====
  109.       MMODEL=IPMODL
  110.       NSOUS=KMODEL(/1)
  111. C
  112.       KEL22 = 0
  113.       DO ISOUS = 1,NSOUS
  114.         IMODEL=KMODEL(ISOUS)
  115.         IF (FORMOD(1).EQ.'CHARGEMENT') KEL22 = KEL22 + 1
  116.       ENDDO
  117. C
  118. C =====
  119. C  1.2 - Cas des modes de calculs en DEFORMATIONS GENERALISEES
  120. C        En mecanique, on conserve le CHPOINT de deplacements pour
  121. C        calculer les deplacements du point support en DPGE (IPCHP1)
  122. C =====
  123.       IPCHP1 = IPCHL1
  124. C =====
  125. C  1.3 - Activation du MCHELM resultat du champ de gradients
  126. C =====
  127.       L1=8
  128.       N1=NSOUS-KEL22
  129.       N3=6
  130.       SEGINI,MCHELM
  131.       TITCHE='GRADIENT'
  132.       IFOCHE=IFOUR
  133.       IPCHL1=MCHELM
  134. C =====
  135. C  1.4 - Les composantes des champs de deplacement/temperature, de
  136. C        gradient resultat sont toutes du meme type ('REAL*8') sur tout
  137. C        le modele IPMODL. Le segment MOTYCH de type NOTYPE associe est
  138. C        donc initialise une seule fois.
  139. C =====
  140.       NBTYPE=1
  141.       SEGINI,NOTYPE
  142.       TYPE(1)='REAL*8'
  143.       MOTYCH=NOTYPE
  144.  
  145. C  2 - BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE (iSou)
  146. C ========================================================
  147.       isouss=0
  148.       DO 2000 iSou=1,NSOUS
  149. C =====
  150. C  2.1 - Quelques initialisations
  151. C =====
  152.         NDEP=0
  153.  
  154.         IF(COMAUT) THEN
  155.           MODEPL=0
  156.         ENDIF
  157.         IVADEP=0
  158.         NGRA=0
  159.         MOGRAD=0
  160.         IVAGRA=0
  161.         MOCARA=0
  162.         IVACAR=0
  163.         MOMATR=0
  164.         IVAMAT=0
  165.         MWRK1=0
  166.         MWRK2=0
  167.         MWRK3=0
  168.         MWRK4=0
  169.         MCHAML=0
  170.         MELVAL=0
  171.         MVELCH=0
  172.  
  173. C =====
  174. C  2.2 - Activation du sous-modele (iSou)
  175. C =====
  176.         IMODEL=KMODEL(iSou)
  177. C
  178.         IF (FORMOD(1).EQ.'CHARGEMENT')  GOTO 2000
  179. C
  180.         NFOR = formod(/2)
  181.         CALL PLACE(FORMOD,NFOR,iliais,'LIAISON')
  182.         iaffai=1
  183.         DO iou=1,matmod(/2)
  184.           if (matmod(iou).eq.'MODAL' .or. matmod(iou).eq.'STATIQUE' .or.
  185.      $        matmod(iou).eq.'IMPEDANCE') iaffai=0
  186.         ENDDO
  187.         IF (iaffai.eq.0 .or. iliais.ne.0)  GOTO 2000
  188.         MELE=NEFMOD
  189. * au cas ou il y en aurait besoin
  190.         IF (mele.eq.22.or.mele.eq.259.or.mele.eq.50000) goto 2000
  191.         isouss=isouss+1
  192.         IPMAIL=IMAMOD
  193.         CONM=CONMOD
  194. C =====
  195. C  2.3 - Determination ...
  196. C =====
  197.         CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,iOK)
  198.         IF (iOK.EQ.0) GOTO 200
  199.         iOK=0
  200. C =====
  201. C  2.4 - Determination de la nature du materiau et verification
  202. C =====
  203.         NFOR=FORMOD(/2)
  204.         CMATE = CMATEE
  205.         MATE  = IMATEE
  206. *NU     INAT  = INATUU
  207.         IF (CMATE.EQ.' ') THEN
  208.           CALL ERREUR(251)
  209.           GOTO 200
  210.         ENDIF
  211.         CALL PLACE(FORMOD,NFOR,ITHEHY,'THERMOHYDRIQUE')
  212.         CALL PLACE(FORMOD,NFOR,ITHER ,'THERMIQUE'     )
  213.         CALL PLACE(FORMOD,NFOR,IDIFF ,'DIFFUSION'     )
  214. C =====
  215. C  2.5 - Recuperation d'informations lies au maillage IPMAIL
  216. C =====
  217.         MELEME=IPMAIL
  218.         NBNN=NUM(/1)
  219.         NBELEM=NUM(/2)
  220.         NBNO=NBNN
  221. C =====
  222. C  2.6 - Recuperation d'informations sur l'element fini du sous-modele
  223. C        suivant la formulation du modele (MECANIQUE ou THERMIQUE)
  224. C =====
  225. C SP 07/08 : NII=Nombre Inconnues Independantes
  226. C            (e.g. T,Pc,Pg en Thermohydrique)
  227.         NII=1
  228.         IPINF=0
  229.         IF (ITHEHY.NE.0) THEN
  230.           MFR=65
  231.           CALL TSHAPE(MELE,'GAUSS',IPMINT)
  232.           IPMIN1=0
  233.           NII=3
  234.           LRE=NII*NBNN
  235. C*OF : Valeur de LW ?
  236.           LW=1700
  237.           NSTRS=0
  238.           LDPGE = .FALSE.
  239.           NDPGE = 0
  240.         ELSE IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  241.           MFR=NUMMFR(MELE)
  242.           CALL TSHAPE(MELE,'GAUSS',IPMINT)
  243.           IPMIN1=0
  244.           IF (MFR.EQ.5 .OR. MFR.EQ.9) THEN
  245.             CALL TSHAPE(MELE,'NOEUD',IPMIN1)
  246.           ENDIF
  247.           IF (MFR.EQ.3 .OR. MFR.EQ.5 .OR. MFR.EQ.9) THEN
  248.             LRE=3*NBNN
  249.           ELSE
  250.             LRE=NBNN
  251.           ENDIF
  252. C*OF : Valeur de LW ?
  253.           LW    = 1700
  254.           NSTRS = 0
  255.           LDPGE = .FALSE.
  256.           NDPGE = 0
  257.         ELSE
  258.           if(infmod(/1).lt.7)then
  259.             CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  260.             INFO=IPINF
  261.             IF (IERR.NE.0) GOTO 200
  262.             MFR=INFELL(13)
  263.             IPMINT=INFELL(11)
  264.             IPMIN1=INFELL(12)
  265.             LRE=INFELL(9)
  266.             LW=INFELL(7)
  267.             LHOOK=INFELL(10)
  268.             NSTRS=INFELL(16)
  269.             segsup info
  270.           else
  271.             MFR=INFELE(13)
  272. *            IPMINT=INFELE(11)
  273.             ipmint=infmod(7)
  274.             IPMIN1=INFMOD(8)
  275.             LRE=INFELE(9)
  276.             LW=INFELE(7)
  277.             LHOOK=INFELE(10)
  278.             NSTRS=INFELE(16)
  279.           endif
  280.           CALL INFDPG(MFR,IFOUR, LDPGE,NDPGE)
  281.         ENDIF
  282.  
  283. C =====
  284. C  2.6 - Recherche des DDL du noeud support des def. planes generalisees
  285. C        Dans ce cas, IPCHP1 est fourni a GRAD via IPCHL1 (cf. 1.3)
  286. C =====
  287.         IF (LDPGE) THEN
  288.           IF (IPCHP1.EQ.0) THEN
  289.             CALL ERREUR(621)
  290.             GOTO 200
  291.           ENDIF
  292.           IIPDPG = imodel.IPDPGE
  293.           IIPDPG = IPTPOI(IIPDPG)
  294.           IF (IIPDPG.EQ.0) THEN
  295.             CALL ERREUR(925)
  296.             CALL ERREUR(5)
  297.             GOTO 200
  298.           ENDIF
  299.           CALL DEPDPG(IPCHP1,UDPGE(1),UDPGE(2),UDPGE(3),IIPDPG)
  300.         ELSE
  301.           IIPDPG = 0
  302.         ENDIF
  303. C =====
  304. C  2.7 - Segment d'integration
  305. C =====
  306.         MINTE=IPMINT
  307.         NBPGAU=POIGAU(/1)
  308. C =====
  309. C  2.8 - Recuperation des noms des caracteristiques GEOMETRIQUES
  310. C        Verification de leur presence dans le MCHAML (IPCHE1)
  311. C =====
  312.         NBROBL=0
  313.         NBRFAC=0
  314.         IVECT =0
  315.         NOTYPE = MOTYCH
  316.        if (iaffai.eq.1 .and. iliais.eq.0) then
  317.  
  318. C= 2.8.1 - Elements COQUES : epaisseur et excentrement
  319.         IF (MFR.EQ.3 .OR. MFR.EQ.5 .OR. MFR.EQ.9) THEN
  320.           NBROBL=1
  321.           NBRFAC=1
  322.           SEGINI,NOMID
  323.           LESOBL(1)='EPAI'
  324.           LESFAC(1)='EXCE'
  325.           MOCARA=NOMID
  326.  
  327. C= 2.8.2 - Formulation THERMIQUE et DIFFUSION : Elements BARRes, TUY2 et TUY3
  328.         ELSEIF (MFR.EQ.27 .OR. MFR.EQ.79) THEN
  329.           NBROBL=0
  330.           NBRFAC=0
  331.  
  332. C= 2.8.3 - Elements BARREs EXCENTREES : section, excentrements et orientation
  333.         ELSE IF (MFR.EQ.49) THEN
  334.           NBROBL=6
  335.           SEGINI NOMID
  336.           MOCARA=NOMID
  337.           LESOBL(1)='SECT'
  338.           LESOBL(2)='EXCZ'
  339.           LESOBL(3)='EXCY'
  340.           LESOBL(4)='VX  '
  341.           LESOBL(5)='VY  '
  342.           LESOBL(6)='VZ  '
  343.  
  344. C= 2.8.4 - Elements POUTRES
  345.         ELSE IF (MFR.EQ.7) THEN
  346.           IF (CMATE.EQ.'SECTION') THEN
  347.             NBROBL=0
  348.             NBRFAC=3
  349.             SEGINI NOMID
  350.             MOCARA=NOMID
  351.             LESFAC(1)='VX'
  352.             LESFAC(2)='VY'
  353.             LESFAC(3)='VZ'
  354.             IVECT=1
  355.  
  356.           ELSE
  357.             IF(IFOUR.EQ.2) THEN
  358.               NBROBL=4
  359.               NBRFAC=5
  360.               SEGINI NOMID
  361.               MOCARA=NOMID
  362.               LESOBL(1)='TORS'
  363.               LESOBL(2)='INRY'
  364.               LESOBL(3)='INRZ'
  365.               LESOBL(4)='SECT'
  366.               LESFAC(1)='SECY'
  367.               LESFAC(2)='SECZ'
  368.               LESFAC(3)='VX'
  369.               LESFAC(4)='VY'
  370.               LESFAC(5)='VZ'
  371.               IVECT=1
  372.             ELSEIF(IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3) THEN
  373.               NBRFAC=1
  374.               NBROBL=2
  375.               SEGINI NOMID
  376.               MOCARA=NOMID
  377.               LESOBL(1)= 'SECT'
  378.               LESOBL(2)= 'INRZ'
  379.               LESFAC(1)= 'SECY'
  380.             ENDIF
  381.           ENDIF
  382. C= 2.8.5 - Elements POUTRES TIMO 2D :
  383. C*      non defini actuellement
  384. C= 2.8.6 - Formulation MECANIQUE : Elements TUYAUX
  385.         ELSE IF (MFR.EQ.13) THEN
  386.           NBROBL=2
  387.           NBRFAC=5
  388.           SEGINI NOMID
  389.           MOCARA=NOMID
  390.           LESOBL(1)='EPAI'
  391.           LESOBL(2)='RAYO'
  392.           LESFAC(1)='RACO'
  393.           LESFAC(2)='CISA'
  394.           LESFAC(3)='VX'
  395.           LESFAC(4)='VY'
  396.           LESFAC(5)='VZ'
  397.           IVECT=1
  398.  
  399. C==DEB= FORMULATION HHO ================================================
  400.         ELSE IF (MFR.EQ.HHO_MFR_ELEMENT) THEN
  401.           IF (MELE.EQ.HHO_NUM_ELEMENT) THEN
  402.             nbrobl = 1
  403.             nbrfac = 0
  404.             SEGINI,nomid
  405.             nomid.LESOBL(1) = 'BHHO'
  406.             MOCARA = nomid
  407.             nbtype = 1
  408.             SEGINI,NOTYPE
  409.             notype.TYPE(1) = 'POINTEURLISTREEL'
  410.           END IF
  411. C==FIN= FORMULATION HHO ================================================
  412.  
  413.         ENDIF
  414.        endif
  415.         NCARA=NBROBL
  416.         NCARF=NBRFAC
  417.         NCAR =NBROBL+NBRFAC
  418.         MOTYPE=NOTYPE
  419. C= 2.8.x - Verification de la presence des caracteristiques dans IPCHE1
  420.         IF (NCAR.NE.0) THEN
  421.           IF (IPCHE1.NE.0) THEN
  422.             CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,
  423.      .                  INFOS,3,IVACAR)
  424.             IF (IERR.NE.0) GOTO 220
  425.           ELSE
  426.             MOTERR(1:8)='CARACTER'
  427.             MOTERR(9:12)=NOMTP(MELE)
  428.             MOTERR(13:20)='GRAD'
  429.             CALL ERREUR(145)
  430.             GOTO 220
  431.           ENDIF
  432.         ENDIF
  433.         if (MOTYPE.NE.MOTYCH) SEGSUP,NOTYPE
  434. C =====
  435. C  2.9.1 - Traitement particulier dans le cas de l'element COQUE DST
  436. C          Recuperation des donnees contenues dans la matrice de HOOKE
  437. C          Verification de leur presence dans le MCHAML (IPCHE1)
  438. C =====
  439.         NMATR=0
  440.         NMATF=0
  441.         NMATT=0
  442.         IF (MELE.EQ.93) THEN
  443.           IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN
  444.             NBROBL=2
  445.             NBRFAC=0
  446.             SEGINI,NOMID
  447.             LESOBL(1)='YOUN'
  448.             LESOBL(2)='NU  '
  449.             MOMATR=NOMID
  450.             NMATR=NBROBL
  451.             NMATF=NBRFAC
  452.             IF (IPCHE1.NE.0) THEN
  453.               CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYCH,1,
  454.      .                    INFOS,3,IVAMAT)
  455.               IF (IERR.NE.0) GOTO 230
  456.             ELSE
  457.               MOTERR(1:8)='CARACTER'
  458.               MOTERR(9:12)=NOMTP(MELE)
  459.               MOTERR(13:20)='GRAD'
  460.               CALL ERREUR(145)
  461.               GOTO 230
  462.             ENDIF
  463.             NMATT=NMATR+NMATF
  464.             MPTVAL=IVAMAT
  465.             NBGMAT=0
  466.             NELMAT=0
  467.             DO i=1,NMATT
  468.               IF (IVAL(i).NE.0)THEN
  469.                 MELVAL=IVAL(i)
  470.                 NBGMAT=MAX(NBGMAT,VELCHE(/1))
  471.                 NELMAT=MAX(NELMAT,VELCHE(/2))
  472.               ENDIF
  473.             ENDDO
  474.           ENDIF
  475.         ENDIF
  476.  
  477. C =====
  478. C  2.9.2 - Cas d'un joint unidimensionnel JOI1
  479. C   Chargement des vecteurs situes dans les caracteristiques materiau
  480. C =====
  481.        IF(MFR.EQ.75) THEN
  482.           IF(IDIM.EQ.3) THEN
  483.              NBROBL=6
  484.              NBRFAC=0
  485.              SEGINI NOMID
  486.              MOMATR=NOMID
  487.              LESOBL(1)='V1X'
  488.              LESOBL(2)='V1Y'
  489.              LESOBL(3)='V1Z'
  490.              LESOBL(4)='V2X'
  491.              LESOBL(5)='V2Y'
  492.              LESOBL(6)='V2Z'
  493.              NMATR=NBROBL
  494.              NMATF=NBRFAC
  495.           ELSE IF(IDIM.EQ.2) THEN
  496.              NBROBL=2
  497.              NBRFAC=0
  498.              SEGINI NOMID
  499.              MOMATR=NOMID
  500.              LESOBL(1)='V1X'
  501.              LESOBL(2)='V1Y'
  502.              NMATR=NBROBL
  503.              NMATF=NBRFAC
  504.           ENDIF
  505.           MOTYPE=MOTYCH
  506. *
  507.          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  508.          IF (IERR.NE.0) GOTO 2000
  509. *
  510.          NMATT=NMATR+NMATF
  511.  
  512.          IF(ISUP1.EQ.1)THEN
  513.            CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  514.            IF(IERR.NE.0)THEN
  515.               ISUP1=0
  516.               GOTO 2000
  517.            ENDIF
  518.          ENDIF
  519.          MPTVAL=IVAMAT
  520.          NBGMAT = 0
  521.          NELMAT = 0
  522.          DO 11265 IM=1,NMATT
  523.            IF(IVAL(IM).NE.0)THEN
  524.              MELVAL=IVAL(IM)
  525.              IF (CMATE.EQ.'SECTION') THEN
  526.                NBGMAT=MAX(NBGMAT,IELCHE(/1))
  527.                NELMAT=MAX(NELMAT,IELCHE(/2))
  528.              ELSE
  529.                NBGMAT=MAX(NBGMAT,VELCHE(/1))
  530.                NELMAT=MAX(NELMAT,VELCHE(/2))
  531.              ENDIF
  532.            ENDIF
  533. 11265    CONTINUE
  534.         nmattd=nmatt
  535.         ivamtd= ivamat
  536.        ENDIF
  537. C ======
  538. C  2.10 - Recuperation des noms des composantes de DEPL. ou T
  539. C         Verification de leur presence dans le MCHAML (IPCHE2)
  540. C*OF Par abus : MODEPL noms des composantes de DEPL et de Temperatures
  541. C ======
  542.        IF(COMAUT) THEN
  543.          IF(LNOMID(1).NE.0) THEN
  544.            NOMID =LNOMID(1)
  545.            MODEPL=NOMID
  546.            ndep  =LESOBL(/2)
  547.            NFAC  =LESFAC(/2)
  548.            LSUPDP=.FALSE.
  549.          ELSE
  550.            LSUPDP=.TRUE.
  551.            IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  552.              CALL IDTEMP(IMODEL,IFOUR,MODEPL,NDEP,NFAC)
  553.              IF (MFR.EQ.1) THEN
  554.              ELSE IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  555.              ENDIF
  556.            ELSE
  557.              CALL IDPRIM(IMODEL,MFR,MODEPL,NDEP,NFAC)
  558.            ENDIF
  559.          ENDIF
  560.        ELSE
  561.          LSUPDP=.FALSE.
  562.          NOMID=MODEPL
  563.          SEGACT NOMID
  564.          ndep=LESOBL(/2)
  565.          NFAC=LESFAC(/2)
  566.        ENDIF
  567. C==DEB= FORMULATION HHO ================================================
  568.         IF (MELE .EQ. HHO_NUM_ELEMENT) GOTO 2750
  569. C==FIN= FORMULATION HHO ================================================
  570.        CALL KOMCHA(IPCHE2,IPMAIL,CONM,MODEPL,MOTYCH,1,INFOS,3,IVADEP)
  571.        IF (IERR.NE.0) GOTO 240
  572.  
  573.  2750   CONTINUE
  574. C ======
  575. C  2.11 - Recuperation des noms des composantes de gradient
  576. C ======
  577.        IF(LNOMID(3).NE.0) then
  578.          MOGRAD= LNOMID(3)
  579.          NOMID = MOGRAD
  580.          SEGACT,NOMID
  581.          NGRA  = LESOBL(/2)
  582.          NFAC  = LESFAC(/2)
  583.          LSUPGD=.FALSE.
  584.        ELSE
  585.          LSUPGD=.TRUE.
  586.          CALL IDGRAD(IMODEL,IFOUR,MOGRAD,NGRA,NFAC)
  587.          NOMID=MOGRAD
  588.          SEGACT,NOMID
  589.        ENDIF
  590.  
  591. C ======
  592. C  2.12 - Initialisation du MCHAML des gradients (MCHAML)
  593. C         associe au modele elementaire iSou (de maillage IPMAIL)
  594. C         Remplissage des donnees associees a MCHAML dans MCHELM(global)
  595. C ======
  596. C= 2.12.1 - Initialisation de MCHAML
  597.         N2=NGRA
  598.         SEGINI,MCHAML
  599. C= 2.12.2 - Remplissage de MCHEML(iSou)
  600.         CONCHE(iSouss)  = CONMOD
  601.         IMACHE(iSouss)  = IPMAIL
  602.         ICHAML(iSouss)  = MCHAML
  603.         INFCHE(iSouss,1)= 0
  604.         INFCHE(iSouss,2)= 0
  605.         INFCHE(iSouss,3)= NIFOUR
  606.         INFCHE(iSouss,4)= IPMINT
  607.         INFCHE(iSouss,5)= 0
  608.         IF (ITHEHY.NE.0 .OR. ITHER.NE.0  .OR. IDIFF.NE.0) THEN
  609.           INFCHE(iSouss,6)=6
  610.         ELSE
  611.           INFCHE(iSouss,6)=5
  612.         ENDIF
  613.  
  614. C= 2.12.3 - Initialisation des N2 MELVAL associes a MCHAML
  615. C=          Fin du remplissage de MCHAML
  616. C==DEB= FORMULATION HHO ================================================
  617.         IF (MELE .EQ. HHO_NUM_ELEMENT) THEN
  618.           N1PTEL = NBPGAU
  619.           N1EL   = MELEME.NUM(/2)
  620.           GOTO 2751
  621.         END IF
  622. C==FIN= FORMULATION HHO ================================================
  623.         N1EL  =0
  624.         N1PTEL=0
  625.         MPTVAL=IVADEP
  626.         DO i=1,NDEP
  627.           MELVAL=IVAL(i)
  628.           N1PTEL=MAX(N1PTEL,VELCHE(/1))
  629.           N1EL  =MAX(N1EL  ,VELCHE(/2))
  630.         ENDDO
  631.  2751   CONTINUE
  632.         IF (N1PTEL.EQ.1 .OR. NBPGAU.EQ.1) THEN
  633.           N1PTEL=1
  634.         ELSE
  635.           N1PTEL=NBPGAU
  636.         ENDIF
  637.         N1EL=MIN(N1EL,NBELEM)
  638. *        write(6,*) 'N1PTEL,N1EL=',N1PTEL,N1EL
  639.         N2PTEL= 0
  640.         N2EL  = 0
  641.         NSR   = 1
  642.         NCOSOR= NGRA
  643.         SEGINI,MPTVAL
  644.         NOMID = MOGRAD
  645.         DO i=1, NGRA
  646.           NOMCHE(i)=LESOBL(i)
  647.           TYPCHE(i)='REAL*8'
  648.           SEGINI,MELVAL
  649.           IELVAL(i)=MELVAL
  650.           IVAL(i)  =MELVAL
  651.         ENDDO
  652.         IVAGRA=MPTVAL
  653.  
  654. C ======
  655. C  2.13 - Initialisations de quelques valeurs
  656. C ======
  657.  
  658. C POUR les XFEM on fait un cas particulier inspire du cas massif
  659.         IF (MFR.EQ.63) THEN
  660.           CALL GRAD1X(IMODEL,IVADEP,LRE,IVAGRA,NGRA,
  661.      &                IPMINT,IPMIN1,IIPDPG,IOK)
  662.           GOTO 260
  663.  
  664. C==DEB= FORMULATION HHO ================================================
  665.         ELSE IF (MELE.EQ.HHO_NUM_ELEMENT) THEN
  666.           iOK = 1
  667.           CALL HHOEPS('GRAD', IMODEL, IPCHP1, MODEPL,
  668.      &                        IIPDPG,UDPGE(1),UDPGE(2),UDPGE(3),
  669.      &                        IVACAR, NCARA, IPMINT,NBPGAU,
  670.      &                        IVAGRA,NGRA, iret)
  671.           IF (iret.NE.0) THEN
  672.             CALL ERREUR(iret)
  673.             iOK = 0
  674.           END IF
  675.           GOTO 260
  676. C==FIN= FORMULATION HHO ================================================
  677.         ENDIF
  678.  
  679. cbp     NDDD=NDEP -> ne prend pas en compte les composantes facultatives
  680.         MPTVAL=IVADEP
  681.         NDDD=IVAL(/1)
  682. C* Attention si composantes facultatives en DPGE ??
  683.         IF (LDPGE) NDDD=NDEP-NDPGE
  684. *
  685.         IF (MFR.EQ.77) THEN
  686. *         zones cohesives : on se limite aux composantes obligatoires
  687.           NDDD=NDEP
  688.         ENDIF
  689.  
  690.         IF (MFR.EQ.29) THEN
  691.           i=NGRA
  692.           NGRA=i*NBNO
  693.           SEGINI,MWRK1
  694.           NGRA=i
  695.         ELSE
  696.           SEGINI,MWRK1
  697.         ENDIF
  698. C
  699.         IF (ITHEHY.NE.0) THEN
  700.           LREII =LRE /NII
  701.           NGRAII=NGRA/NII
  702.           JG    =LREII
  703.           SEGINI,MLREE1
  704.           JG=NGRAII
  705.           SEGINI,MLREE2
  706.         ENDIF
  707.  
  708.         NOELE=MELE
  709.         IF (ITHEHY.NE.0) THEN
  710.           NOELE=57
  711.         ELSE IF (ITHER.NE.0  .OR. IDIFF.NE.0) THEN
  712.           IF(MFR .EQ. 1) THEN
  713.             NOELE=57
  714.           ENDIF
  715.         ENDIF
  716.  
  717. C ======
  718. C  2.14 - Boucle sur les elements du sous-modele elementaire
  719. C ======
  720.         DO 100 IB=1,NBELEM
  721. C= 2.14.1 - Recuperation des coordonnees des noeuds de l'element
  722.           CALL DOXE(XCOOR,IDIM,NBNO,NUM,IB,XE)
  723.  
  724. C= 2.14.2 - Recuperation des deplacements/temperatures aux noeuds
  725. C=          Traitement dans les cas des modes generalises
  726.           MPTVAL=IVADEP
  727.           IE=1
  728.           DO iGau=1,NBNN
  729.             DO i=1,NDDD
  730.               MELVAL=IVAL(i)
  731.               IF (MELVAL.NE.0) THEN
  732.                 IGMN=MIN(iGau,VELCHE(/1))
  733.                 IBMN=MIN(IB,VELCHE(/2))
  734.                 XDDL(IE)=VELCHE(IGMN,IBMN)
  735.               ELSE
  736.                 XDDL(IE)=XZero
  737.               ENDIF
  738.               IE=IE+1
  739.             ENDDO
  740.           ENDDO
  741.           IF (NDPGE.GT.0) THEN
  742.             DO i=1,NDPGE
  743.               XDDL(IE)=UDPGE(i)
  744.               IE=IE+1
  745.             ENDDO
  746.           ENDIF
  747.  
  748. C= 2.14.3 - Branchement suivant l'element fini
  749. c            1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20
  750.       GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  751. c           21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
  752.      .      99,99, 4, 4, 4, 4,27,28,29,99,99,99,99,99,99,99,99,99,99,99,
  753. c           41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
  754.      .      41,29,99,44,99,46,99,99,49,99,99,99,99,99,99,41, 4, 4, 4, 4,
  755. c           61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
  756.      .       4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,99,99,
  757. c           81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100
  758.      .      99,99,99,29,85,99,99,88,99,99,99,99,93,99,99,99,99,99,99,99,
  759. c     100 +  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20
  760.      .      99,99,99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
  761. c     100 + 21 22
  762.      .       4, 4),MELE
  763.           IF (MELE.EQ.183.OR. MELE.EQ.184) GOTO 4
  764.           IF (MELE.GE.191.AND.MELE.LE.194) GOTO 4
  765.           IF (MELE.EQ.265                ) GOTO 265
  766.           IF (MELE.EQ.266                ) GOTO 266
  767.           IF (MELE.EQ.267                ) GOTO 267
  768.           IF (MELE.EQ.269.OR.MELE.EQ.270 ) GOTO 46
  769.           IF (MELE.EQ.273.OR.MELE.EQ.274 ) GOTO 4
  770.           IF (MELE.EQ.279.OR.MELE.EQ.280 ) GOTO 4
  771.  99       CONTINUE
  772. CC*OF On ne veut plus sortir sur une erreur :
  773. C*        MOTERR(1:4)=NOMTP(MELE)
  774. C*        MOTERR(9:12)='GRADIENT'
  775. C*        iMess=86
  776. C*OF On met un champ de gradient nul pour les elements non implementes !
  777.           N1PTEL=1
  778.           N1EL  =1
  779.           N2PTEL=0
  780.           N2EL  =0
  781.           DO i=1,IELVAL(/1)
  782.             MELVAL=IELVAL(i)
  783.             SEGADJ,MELVAL
  784.             VELCHE(1,1)=XZero
  785.           ENDDO
  786.           iOK=1
  787.           GOTO 250
  788.  
  789. C= 2.14.4 - Elements MASSIFS et INCOMPRESSIBLES
  790.  4        CONTINUE
  791.           IF (IB.EQ.1) SEGINI,MWRK2
  792.  
  793. C- Elements MASSIFS et INCOMPRESSIBLES en MECANIQUE
  794. C- Calcul des coeff de modification de b-barre
  795. C= NOM  :   ICT3, ICQ4, ICT6, ICQ8, ICC8, ICT4, ICP6, IC20, IC10, IC15
  796. C= MELE :    69 ,  70 ,  71 ,  72 ,  73 ,  74 ,  75 ,  76 ,  77 ,  78
  797.           IF (MFR.EQ.31) THEN
  798.             CALL BBCAL3(NOELE,NBNO,MFR,IDIM,XE,
  799.      &                  NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  800.      &                  NGRA,LRE,IFOUR,NIFOUR,A,BBX,
  801.      &                  SHPTOT,SHPWRK,BGR,BB,PP,NOER)
  802.             IF (NOER.NE.0) THEN
  803.               CALL ERREUR(noer)
  804.               RETURN
  805.             ENDIF
  806.           ENDIF
  807.  
  808.           ISDJC=0
  809.           DO iGau=1,NBPGAU
  810. C -- Calcul de la matrice B et du jacobien au point de Gauss IGAU
  811.             IF (ITHEHY.NE.0) THEN
  812. C             Elements massifs en 'THERMOHYDRIQUE'
  813.               CALL BGRMAS(iGau,NOELE,NBNO,LREII,IFOUR,NGRAII,NIFOUR,XE,
  814.      &                    XZero,SHPTOT,SHPWRK,BB,BGR,DJAC,IIPDPG)
  815.             ELSE
  816.               IF (MFR.EQ.71) THEN
  817. C               Elements massifs en 'ELECTROSTATIQUE'
  818.                 CALL BELEC(XE,SHPTOT(1,1,IGAU),NBNO,NGRA,+1,
  819.      &                     SHPWRK,BGR,DJAC)
  820.               ELSE IF (MFR.EQ.73) THEN
  821. C               Elements massifs en 'DIFFUSION'
  822.                 CALL BDIFF(XE,SHPTOT(1,1,IGAU),NBNN,NGRA,+1,
  823.      &                     SHPWRK,BGR,DJAC)
  824.               ELSE
  825. C-              Elements MASSIFS et INCOMPRESSIBLES en MECANIQUE
  826.                 CALL BGRMAS(iGau,NOELE,NBNO,LRE,IFOUR,NGRA,NIFOUR,XE,
  827.      &                      XZero,SHPTOT,SHPWRK,BB,BGR,DJAC,IIPDPG)
  828.  
  829. C En cas d'elements incompressibles : BGR selon la methode B-BARRE
  830.                 IF (MFR.EQ.31) THEN
  831.                   CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  832.      &                      NOELE,NBNO,LRE,IFOUR,NGRA,XE,DJAC,A,BBX,BGR)
  833.                 ENDIF
  834.  
  835.               ENDIF
  836.             ENDIF
  837.             IF (DJAC.LT.XZero) ISDJC=ISDJC+1
  838.             IF (DJAC.EQ.XZero) THEN
  839.               iMess=259
  840.               GOTO 260
  841.             ENDIF
  842.             IF (ITHEHY.NE.0) THEN
  843.               DO KII=1,NII
  844.                 DO LLL=1,LREII
  845.                   MLREE1.PROG(LLL)=XDDL(LLL*NII-(NII-KII))
  846.                 ENDDO
  847.                 CALL BGRDEP(BGR,NGRAII,MLREE1.PROG,LREII,MLREE2.PROG)
  848.                 DO LLL=1,NGRAII
  849.                   GRADI(LLL+(KII-1)*NGRAII)=MLREE2.PROG(LLL)
  850.                 ENDDO
  851.               ENDDO
  852.             ELSE
  853.               IF (MFR.EQ.71 .OR. MFR.EQ.73) THEN
  854. C               Elements massifs en 'ELECTROSTATIQUE' et 'DIFFUSION'
  855.                 CALL BST(   BGR,XDDL,LRE,NGRA,GRADI)
  856.               ELSE
  857.                 CALL BGRDEP(BGR,NGRA,XDDL,LRE,GRADI)
  858.               ENDIF
  859.             ENDIF
  860.             MPTVAL=IVAGRA
  861.             DO i=1,NGRA
  862.               MELVAL=IVAL(i)
  863.               IGMN  =MIN(iGau,VELCHE(/1))
  864.               IBMN  =MIN(IB,VELCHE(/2))
  865.               VELCHE(IGMN,IBMN)=GRADI(i)
  866.             ENDDO
  867.           ENDDO
  868.           IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  869.             iMess=195
  870.             GOTO 260
  871.           ENDIF
  872.           GOTO 100
  873.  
  874. C= 2.14.5 - Elements COQUES COQ3 (thermique - diffusion)
  875.  27       IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  876.             IF (IB.EQ.1) SEGINI,MWRK2
  877.             ISDJC=0
  878.             DO iGau=1,NBPGAU
  879.               CALL CQTGR1(iGau,MELE,NBNN,LRE,IFOUR,NGRA,XE,SHPTOT,
  880.      .                    XDDL,SHPWRK,BGR,DJAC,GRADI)
  881.               IF (IERR.NE.0) GOTO 260
  882.               IF (DJAC.EQ.XZero) THEN
  883.                 iMess=259
  884.                 GOTO 260
  885.               ENDIF
  886.               IF (DJAC.LT.XZero) ISDJC=ISDJC+1
  887.               MPTVAL=IVAGRA
  888.               DO i=1,NGRA
  889.                 MELVAL=IVAL(i)
  890.                 IGMN=MIN(iGau,VELCHE(/1))
  891.                 IBMN=MIN(IB,VELCHE(/2))
  892.                 VELCHE(IGMN,IBMN)=GRADI(i)
  893.               ENDDO
  894.             ENDDO
  895.             IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  896.               iMess=195
  897.               GOTO 260
  898.             ENDIF
  899.           ELSE
  900. C= COQ3 mecanique : un point d'integration au centre de gravite
  901.             IF (IB.EQ.1) SEGINI,MWRK3
  902.             CALL COQ3GR(XE,XDDL,GRADI,WORK)
  903.             MPTVAL=IVAGRA
  904.             DO i=1,NGRA
  905.               MELVAL=IVAL(i)
  906.               IBMN=MIN(IB,VELCHE(/2))
  907.               VELCHE(1,IBMN)=GRADI(i)
  908.             ENDDO
  909.           ENDIF
  910.           GOTO 100
  911. C= 2.14.6 - Elements DKT
  912.  28       IF (IB.EQ.1) SEGINI,MWRK2,MWRK4
  913.           CALL VPAST(XE,BPSS)
  914.           CALL VCORLC(XE,XEL,BPSS)
  915.           CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  916.           EPAIST=XZero
  917.           MPTVAL=IVACAR
  918.           IF (IVAL(1).NE.0) THEN
  919.             MELVAL=IVAL(1)
  920.             IBMN=MIN(IB,VELCHE(/2))
  921.             DO iGau=1,NBPGAU
  922.               IGMN=MIN(iGau,VELCHE(/1))
  923.               EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  924.             ENDDO
  925.             EPAIST=EPAIST/NBPGAU
  926.           ENDIF
  927.           DO iGau=1,NBPGAU
  928.             MPTVAL=IVACAR
  929.             MELVAL=IVAL(2)
  930.             IF (MELVAL.NE.0) THEN
  931.               IBMN=MIN(IB,VELCHE(/2))
  932.               EXCEN=VELCHE(1,IBMN)
  933.             ELSE
  934.               EXCEN=XZero
  935.             ENDIF
  936.             CALL BGRMAS(iGau,MELE,NBNO,LRE,IFOUR,NGRA,0,XEL,
  937.      .                  EXCEN,SHPTOT,SHPWRK,BB,BGR,DJAC,IIPDPG)
  938.             CALL BGRDEP(BGR,NGRA,XDDLOC,LRE,GRADI)
  939.             MPTVAL=IVAGRA
  940.             DO i=1,NGRA
  941.               MELVAL=IVAL(i)
  942.               IGMN=MIN(iGau,VELCHE(/1))
  943.               IBMN=MIN(IB,VELCHE(/2))
  944.               VELCHE(IGMN,IBMN)=GRADI(i)
  945.             ENDDO
  946.           ENDDO
  947.           GOTO 100
  948. C= 2.14.7 - Elements COQ8 et COQ6
  949.  41       IF (IB.EQ.1) THEN
  950.             SEGINI,MWRK3
  951.             MINTE1=IPMIN1
  952.             SEGACT,MINTE1
  953.           ENDIF
  954. C= Recuperation de l'epaisseur et des excentrements
  955.           MPTVAL=IVACAR
  956.           EPAIST=XZero
  957.           MELVAL=IVAL(1)
  958.           IF (MELVAL.NE.0) THEN
  959.             IBMN=MIN(IB,VELCHE(/2))
  960.             DO iGau=1,NBPGAU
  961.               IGMN=MIN(iGau,VELCHE(/1))
  962.               EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  963.             ENDDO
  964.             EPAIST=EPAIST/NBPGAU
  965.           ENDIF
  966.           EXCEN=XZero
  967.           MELVAL=IVAL(2)
  968.           IF (MELVAL.NE.0) THEN
  969.             IBMN=MIN(IB,VELCHE(/2))
  970.             DO iGau=1,NBPGAU
  971.               IGMN=MIN(iGau,VELCHE(/1))
  972.               EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  973.             ENDDO
  974.             EXCEN=EXCEN/NBPGAU
  975.           ENDIF
  976. C= Element thermique
  977.           IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  978.             CALL CQTGR2(XE,NBNN,NBPGAU,LRE,EPAIST,DZEGAU,
  979.      .                  SHPTOT,MINTE1.SHPTOT,XDDL,WORK(1),WORK(1+LRE))
  980.             IE=LRE
  981. C= Element mecanique
  982.           ELSE
  983.             CALL CQ8GRA(XE,NBNO,NBPGAU,LRE,EPAIST,EXCEN,DZEGAU,
  984.      .                  SHPTOT,MINTE1.SHPTOT,XDDL,WORK,IRR)
  985.             IE=0
  986.           ENDIF
  987.           MPTVAL=IVAGRA
  988.           DO iGau=1,NBPGAU
  989.             DO i=1,NGRA
  990.               MELVAL=IVAL(i)
  991.               IGMN=MIN(iGau,VELCHE(/1))
  992.               IBMN=MIN(IB,VELCHE(/2))
  993.               IE=IE+1
  994.               VELCHE(IGMN,IBMN)=WORK(IE)
  995.             ENDDO
  996.           ENDDO
  997.           GOTO 100
  998.  
  999. C= 2.14.8 - Element COQ2
  1000.  44       IF (IB.EQ.1) SEGINI,MWRK2
  1001. C= Element thermique
  1002.           IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  1003.             ISDJC=0
  1004.             DO iGau=1,NBPGAU
  1005.               CALL CQTGR1(iGau,MELE,NBNN,LRE,IFOUR,NGRA,XE,SHPTOT,
  1006.      .                    XDDL,SHPWRK,BGR,DJAC,GRADI)
  1007.               IF (IERR.NE.0) GOTO 260
  1008.               IF (DJAC.EQ.XZero) THEN
  1009.                 iMess=259
  1010.                 GOTO 260
  1011.               ENDIF
  1012.               MPTVAL=IVAGRA
  1013.               DO i=1,NGRA
  1014.                 MELVAL=IVAL(i)
  1015.                 IGMN=MIN(iGau,VELCHE(/1))
  1016.                 IBMN=MIN(IB,VELCHE(/2))
  1017.                 VELCHE(IGMN,IBMN)=GRADI(i)
  1018.               ENDDO
  1019.             ENDDO
  1020. C= Element mecanique
  1021.           ELSE
  1022.             MPTVAL=IVACAR
  1023.             IF (IVAL(1).NE.0) THEN
  1024.               MELVAL=IVAL(1)
  1025.               IBMN=MIN(IB,VELCHE(/2))
  1026.               EPAIST=VELCHE(1,IBMN)
  1027.             ELSE
  1028.               EPAIST=XZero
  1029.             ENDIF
  1030.             DO iGau=1,NBPGAU
  1031.               CALL BGRCQ2(BGR,DJAC,iGau,IFOUR,XE,NIFOUR,
  1032.      .                    QSIGAU,POIGAU,IERT)
  1033.               IF (IERT.NE.0) THEN
  1034.                 IF (IERT.EQ.1) iMess=255
  1035.                 IF (IERT.EQ.2) iMess=256
  1036.                 GOTO 260
  1037.               ENDIF
  1038.               CALL BGRDEP(BGR,NGRA,XDDL,LRE,GRADI)
  1039.               MPTVAL=IVAGRA
  1040.               DO i=1,NGRA
  1041.                 MELVAL=IVAL(i)
  1042.                 IGMN=MIN(iGau,VELCHE(/1))
  1043.                 IBMN=MIN(IB,VELCHE(/2))
  1044.                 VELCHE(IGMN,IBMN)=GRADI(i)
  1045.               ENDDO
  1046.             ENDDO
  1047.           ENDIF
  1048.           GOTO 100
  1049.  
  1050. C= 2.14.8 - Element BARR, TUY2, TUY3 en THERMIQUE et DIFFUSION
  1051.  46       CONTINUE
  1052.           IF (IB.EQ.1) SEGINI,MWRK2
  1053.           DO iGau=1,NBPGAU
  1054. C --        Calcul de la matrice B
  1055.             CALL BDIFF1(XE,SHPTOT(1,1,iGau),NBNN,NGRA,+1,
  1056.      &                     SHPWRK,BGR)
  1057.  
  1058. C --        Calcul du gradient en les Pts d'interet
  1059.             CALL BST(BGR,XDDL,LRE,NGRA,GRADI)
  1060.  
  1061.             MPTVAL=IVAGRA
  1062.             N1PTEL=VELCHE(/1)
  1063.             N1EL  =VELCHE(/2)
  1064.             DO i=1,NGRA
  1065.               MELVAL=IVAL(i)
  1066.               IGMN  =MIN(iGau,N1PTEL)
  1067.               IBMN  =MIN(IB  ,N1EL  )
  1068.               VELCHE(IGMN,IBMN)=GRADI(i)
  1069.             ENDDO
  1070.           ENDDO
  1071.           GOTO 100
  1072.  
  1073. C= 2.14.9 - Element COQ4
  1074.  49       MPTVAL=IVACAR
  1075.           MELVAL=IVAL(1)
  1076.           IF (MELVAL.NE.0) THEN
  1077.             IBMN=MIN(IB,VELCHE(/2))
  1078.             EPAIST=VELCHE(1,IBMN)
  1079.           ELSE
  1080.             EPAIST=XZero
  1081.           ENDIF
  1082.           MELVAL=IVAL(2)
  1083.           IF (MELVAL.NE.0) THEN
  1084.             IBMN=MIN(IB,VELCHE(/2))
  1085.             EXCEN=VELCHE(1,IBMN)
  1086.           ELSE
  1087.             EXCEN=XZero
  1088.           ENDIF
  1089.  
  1090. C= Element thermique/diffusion
  1091.           IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  1092.             IF (IB.EQ.1) THEN
  1093.               SEGINI,MWRK3
  1094.               MINTE1=IPMIN1
  1095.               SEGACT,MINTE1
  1096.             ENDIF
  1097.             CALL CQTGR2(XE,NBNN,NBPGAU,LRE,EPAIST,DZEGAU,
  1098.      .                  SHPTOT,MINTE1.SHPTOT,XDDL,WORK(1),WORK(1+LRE))
  1099.             MPTVAL=IVAGRA
  1100.             IE=LRE
  1101.             DO iGau=1,NBPGAU
  1102.               DO i=1,NGRA
  1103.                 MELVAL=IVAL(i)
  1104.                 IGMN=MIN(iGau,VELCHE(/1))
  1105.                 IBMN=MIN(IB,VELCHE(/2))
  1106.                 IE=IE+1
  1107.                 VELCHE(IGMN,IBMN)=WORK(IE)
  1108.               ENDDO
  1109.             ENDDO
  1110.  
  1111. C= Element mecanique
  1112.           ELSE
  1113.             IF (IB.EQ.1) SEGINI,MWRK2,MWRK4
  1114.             CALL CQ4LOC(XE,XEL,BPSS,IERT,1)
  1115.             IF (IERT.EQ.1) IG1=IB
  1116.             IF (IERT.EQ.3) THEN
  1117.               IERT=0
  1118.               NOPLAN=1
  1119.             ELSE
  1120.               NOPLAN=0
  1121.             ENDIF
  1122.             CALL MATVEC(XDDL,XDDLOC,BPSS,8)
  1123.             DO iGau=1,NBPGAU
  1124.               CALL BGRCQ4(iGau,XEL,SHPTOT,SHPWRK,BGR,DJAC,EXCEN,
  1125.      .                    NOPLAN,IERT)
  1126.               IF (IERT.EQ.1) THEN
  1127.                 iMess=321
  1128.                 GOTO 260
  1129.               ENDIF
  1130.               CALL BGRDEP(BGR,NGRA,XDDLOC,LRE,GRADI)
  1131.               MPTVAL=IVAGRA
  1132.               DO i=1,NGRA
  1133.                 MELVAL=IVAL(i)
  1134.                 IGMN=MIN(iGau,VELCHE(/1))
  1135.                 IBMN=MIN(IB,VELCHE(/2))
  1136.                 VELCHE(IGMN,IBMN)=GRADI(i)
  1137.               ENDDO
  1138.             ENDDO
  1139.           ENDIF
  1140.           GOTO 100
  1141.  
  1142. C= 2.14.10 - Element DST
  1143.  93       IF (IB.EQ.1) THEN
  1144.             NV1=NMATT
  1145.             SEGINI,MWRK2,MWRK3,MWRK4,MVELCH
  1146.           ENDIF
  1147.           CALL VPAST(XE,BPSS)
  1148.           CALL VCORLC(XE,XEL,BPSS)
  1149.           CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  1150. C= Calcul de la moyenne des epaisseurs
  1151.           MPTVAL=IVACAR
  1152.           EPAIST=XZero
  1153.           MELVAL=IVAL(1)
  1154.           IF (MELVAL.NE.0) THEN
  1155.             IBMN=MIN(IB,VELCHE(/2))
  1156.             DO iGau=1,NBPGAU
  1157.               IGMN=MIN(iGau,VELCHE(/1))
  1158.               EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  1159.             ENDDO
  1160.             EPAIST=EPAIST/NBPGAU
  1161.           ENDIF
  1162. C= Calcul de la moyenne des excentrements
  1163.           EXCEN=XZero
  1164.           MELVAL=IVAL(2)
  1165.           IF (MELVAL.NE.0) THEN
  1166.             IBMN=MIN(IB,VELCHE(/2))
  1167.             DO iGau=1,NBPGAU
  1168.               IGMN=MIN(iGau,VELCHE(/1))
  1169.               EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  1170.             ENDDO
  1171.             EXCEN=EXCEN/NBPGAU
  1172.           ENDIF
  1173.           DO iGau=1,NBPGAU
  1174.             MPTVAL=IVAMAT
  1175.             DO i=1,NMATT
  1176.               IF (IVAL(i).NE.0) THEN
  1177.                 MELVAL=IVAL(i)
  1178.                 IGMN=MIN(iGau,VELCHE(/1))
  1179.                 IBMN=MIN(IB,VELCHE(/2))
  1180.                 VALMAT(i)=VELCHE(IGMN,IBMN)
  1181.               ELSE
  1182.                 VALMAT(i)=XZero
  1183.               ENDIF
  1184.             ENDDO
  1185.             IF (iGau.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN
  1186.               CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD1)
  1187.               IF (IRTD1.EQ.0) GOTO 260
  1188.             ENDIF
  1189.             CALL HOOKMU(EPAIST,XZero,LHOOK,DDHOOK,DDHOMU)
  1190.             CALL ZERO(BGR,NGRA,LRE)
  1191. C= Termes de la matrice BGR relatifs aux cisaillements transverses
  1192.             CALL DSTGR2(XEL,NGRA,NSTRS,DDHOMU,WORK(1),WORK(10),
  1193.      .                  WORK(19),BGR)
  1194. C= Termes de la matrice BGR relatifs aux effets de membrane
  1195.             CALL DSTGR1(iGau,NBNO,XEL,NGRA,QSIGAU,ETAGAU,SHPTOT,SHPWRK,
  1196.      .                  EXCEN,WORK(1),WORK(10),WORK(19),BGR,DJAC)
  1197. C= Multiplication de BGR par les deplacements XDDLOC
  1198.             CALL BGRDEP(BGR,NGRA,XDDLOC,LRE,GRADI)
  1199.             MPTVAL=IVAGRA
  1200.             DO i=1,NGRA
  1201.               MELVAL=IVAL(i)
  1202.               IGMN=MIN(iGau,VELCHE(/1))
  1203.               IBMN=MIN(IB,VELCHE(/2))
  1204.               VELCHE(IGMN,IBMN)=GRADI(i)
  1205.             EnDDO
  1206.           ENDDO
  1207.           GOTO 100
  1208.  
  1209. C= 2.14.29 - ElementS POUTRE, TUYA, TIMO
  1210.  29       IF (IB.EQ.1) THEN
  1211.             SEGINI,MWRK2
  1212.             SEGINI,MWRK3
  1213.           ENDIF
  1214.  
  1215. C= Element thermique
  1216.           IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  1217.             IMESS = 86
  1218.             GOTO 260
  1219. C= Element mecanique
  1220.           ELSE
  1221.  
  1222. C  ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  1223.             CALL ZERO(WORK,NCAR,1)
  1224.             DO 4029 IGAU=1,NBNN
  1225.               MPTVAL=IVACAR
  1226.               DO 6029 IC=1,NCAR
  1227.                 IF (IVAL(IC).NE.0) THEN
  1228.                   MELVAL=IVAL(IC)
  1229.                   IBMN=MIN(IB  ,VELCHE(/2))
  1230.                   IGMN=MIN(IGAU,VELCHE(/1))
  1231.                   IF (IGMN.GT.0.AND.IBMN.GT.0) THEN
  1232.                     WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  1233.                   ELSE
  1234.                     WORK(IC)=0.D0
  1235.                   ENDIF
  1236.                 ELSE
  1237.                   WORK(IC)=0.D0
  1238.                 ENDIF
  1239.                 IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  1240.  6029         CONTINUE
  1241.  4029       CONTINUE
  1242.  
  1243. C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  1244. C                   EQUIVALENTE
  1245.             IF (MELE.EQ.42) THEN
  1246.               CISA=WORK(4)
  1247.               VX=WORK(5)
  1248.               VY=WORK(6)
  1249.               VZ=WORK(7)
  1250.               CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
  1251.             ENDIF
  1252.  
  1253. C  ON CALCULE LES GRADIENTS
  1254.             IF (MELE.EQ.84) THEN
  1255.               IF (CMATE.EQ.'SECTION') THEN
  1256.                 IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1257.                   CALL TIMGR2(XE,XDDL,WORK(12),WORK(25))
  1258.                 ELSE
  1259.                   CALL TIMGR1(XE,XDDL,WORK(1),WORK(12),WORK(25))
  1260.                 ENDIF
  1261.  
  1262.               ELSE
  1263.                 IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1264.                   CALL TIMGR2(XE,XDDL,WORK(12),WORK(25))
  1265.                 ELSE
  1266.                   CALL TIMGR1(XE,XDDL,WORK(7),WORK(12),WORK(25))
  1267.                 ENDIF
  1268.               ENDIF
  1269.             ELSE
  1270.               IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1271.                 CALL POUGR2(XE,XDDL,WORK,WORK(12),WORK(25))
  1272.               ELSE
  1273.                 CALL POUGR1(XE,XDDL,WORK,WORK(12),WORK(25))
  1274.               ENDIF
  1275.             ENDIF
  1276. C  REMPLISSAGE
  1277.             DO iGau=1,NBPGAU
  1278.               MPTVAL=IVAGRA
  1279.               DO i=1,NGRA
  1280.                 MELVAL=IVAL(i)
  1281.                 IGMN=MIN(iGau,VELCHE(/1))
  1282.                 IBMN=MIN(IB,VELCHE(/2))
  1283.                 IDECA=11+I+(IGAU-1)*NGRA
  1284.                 VELCHE(IGMN,IBMN)=WORK(IDECA)
  1285.               ENDDO
  1286.             ENDDO
  1287.           ENDIF
  1288.           GOTO 100
  1289. C
  1290. C     ELEMENT JOI2
  1291. C
  1292.  85       IF (IB.EQ.1) THEN
  1293.             SEGINI,MWRK2
  1294.             SEGINI,MWRK4
  1295.           ENDIF
  1296. C= Element thermique
  1297.           IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  1298.             IMESS = 86
  1299.             GO TO 260
  1300. C= Element mecanique
  1301.           ELSE
  1302. C
  1303.          CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1304. C
  1305. C     BOUCLE SUR LES POINTS DE GAUSS
  1306. C
  1307.          DO 4085 IGAU=1,NBPGAU
  1308. C
  1309.             CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1310.      .                                       BGR,DJAC,IRRT)
  1311. C           IRRT.NE.0 JACOBIEN <= 0
  1312.             IF(IRRT.NE.0) THEN
  1313.               INTERR(1)=IB
  1314.               IMESS=612
  1315.               GOTO 260
  1316.             ENDIF
  1317. C
  1318.             CALL BST(BGR,XDDL,LRE,NSTRS,GRADI)
  1319. C
  1320. C     REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS
  1321. C
  1322.             MPTVAL=IVAGRA
  1323.             DO 9085 ICOMP=1,NGRA
  1324.                MELVAL=IVAL(ICOMP)
  1325.                IGMN=MIN(IGAU,VELCHE(/1))
  1326.                IBMN=MIN(IB  ,VELCHE(/2))
  1327.                VELCHE(IGMN,IBMN)=GRADI(ICOMP)
  1328.  9085       CONTINUE
  1329.  4085    CONTINUE
  1330. C
  1331.       ENDIF
  1332.       GOTO 100
  1333. C
  1334. C     ELEMENT JOI4
  1335. C
  1336.  88       IF (IB.EQ.1) THEN
  1337.             SEGINI,MWRK2
  1338.             SEGINI,MWRK4
  1339.           ENDIF
  1340. C= Element thermique
  1341.           IF (ITHER.NE.0 .OR. IDIFF.NE.0) THEN
  1342.             IMESS = 86
  1343.             GO TO 260
  1344. C= Element mecanique
  1345.           ELSE
  1346. C
  1347.          CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  1348. C
  1349. C     BOUCLE SUR LES POINTS DE GAUSS
  1350. C
  1351.          DO 4088 IGAU=1,NBPGAU
  1352. C
  1353.             CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGR,DJAC,IRRT)
  1354. C           IRRT.NE.0 JACOBIEN <= 0
  1355.             IF (IRRT.NE.0) THEN
  1356.               INTERR(1)=IB
  1357.               IMESS = 611
  1358.               GOTO 260
  1359.             ENDIF
  1360. C
  1361.             CALL BST(BGR,XDDL,LRE,NGRA,GRADI)
  1362. C
  1363. C     REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS
  1364. C
  1365.             MPTVAL=IVAGRA
  1366.             DO 9088 ICOMP=1,NGRA
  1367.                MELVAL=IVAL(ICOMP)
  1368.                IGMN=MIN(IGAU,VELCHE(/1))
  1369.                IBMN=MIN(IB  ,VELCHE(/2))
  1370.                VELCHE(IGMN,IBMN)=GRADI(ICOMP)
  1371.  9088       CONTINUE
  1372.  4088    CONTINUE
  1373. C
  1374.       ENDIF
  1375.       GOTO 100
  1376.  
  1377. C= 2.14.265 - JOINT UNIDIMENSIONNEL JOI1
  1378.  265  SEGINI,MWRK2,MWRK3,MWRK4
  1379. C
  1380. C     RANGEMENT DES CARACTERISTIQUES DANS WORK
  1381. C
  1382.       MPTVAL=IVAMAT
  1383.       DO IC=1,NMATT
  1384.         IF(IVAL(IC).NE.0) THEN
  1385.           MELVAL=IVAL(IC)
  1386.           IBMN=MIN(IB,VELCHE(/2))
  1387.           WORK(IC)=VELCHE(1,IBMN)
  1388.         ELSE
  1389.           WORK(IC)=0.D0
  1390.         ENDIF
  1391.       END DO
  1392. C
  1393.       CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  1394. C
  1395. C  CALCUL DES DEPLACEMENTS LOCAUX
  1396. C
  1397.       IAW1 = 101
  1398.       IAW2 = IAW1 + LRE
  1399.       CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM)
  1400. *
  1401. C  ON CALCULE LES GRADIENTS
  1402. *
  1403.       CALL JOIGR1(XDDL,WORK,LRE,NGRA,IDIM)
  1404. C  REMPLISSAGE
  1405.            DO iGau=1,NBPGAU
  1406.              MPTVAL=IVAGRA
  1407.              DO i=1,NGRA
  1408.                MELVAL=IVAL(i)
  1409.                IGMN=MIN(iGau,VELCHE(/1))
  1410.                IBMN=MIN(IB,VELCHE(/2))
  1411. *               IDECA=11+I+(IGAU-1)*NGRA
  1412.                VELCHE(IGMN,IBMN)=WORK(I)
  1413.              ENDDO
  1414.            ENDDO
  1415.           GOTO 100
  1416.  
  1417. C= 2.14.266 - Element ZCO2
  1418.  266      CONTINUE
  1419.           IF (IB.EQ.1) SEGINI,MWRK2,MWRK4
  1420.           DO 2660 iGau=1,NBPGAU
  1421. C     MATRICE JACOBIENNE
  1422.       DO  I=1,NBNO
  1423.        SHPWRK(1,I) = SHPTOT(1,I,IGAU)
  1424.        SHPWRK(2,I) = SHPTOT(2,I,IGAU)
  1425.       ENDDO
  1426. C     TRAITEMENT PARTICULIER POUR LE CAS 2D
  1427. C     SINON, APPEL A DEVOLU
  1428.       IF(IDIM.EQ.2) THEN
  1429.         dXdQsi=0.D0
  1430.         dYdQsi=0.D0
  1431.         DO i=1,NBNO
  1432.           dXdQsi=dXdQsi+SHPWRK(2,i)*XE(1,i)
  1433.           dYdQsi=dYdQsi+SHPWRK(2,i)*XE(2,i)
  1434.         ENDDO
  1435.         DJAC=SQRT(dXdQsi*dXdQsi+dYdQsi*dYdQsi)
  1436. C  ON MULTIPLIE PAR LE RAYON EN AXI
  1437.        IF (IFOUR.EQ.0) THEN
  1438.         RAYON=0.D0
  1439.         DO IRAY=1,NBNO
  1440.          RAYON=RAYON+SHPTOT(1,IRAY,IGAU)*XE(1,IRAY)
  1441.         ENDDO
  1442.         DJAC=DJAC*RAYON
  1443.        ENDIF
  1444.       ELSE
  1445. *        write(ioimp,*) 'option 3d non implementee'
  1446.         GOTO 260
  1447. *        CALL DEVOLU(XE,SHPWRK,MFR,NBNO,IFOUR,NIFOUR,IDIM,1.D0,RR,DJAC)
  1448.       ENDIF
  1449.             IF (DJAC.LT.XZero) ISDJC=ISDJC+1
  1450.             IF (DJAC.EQ.XZero) THEN
  1451.               iMess=259
  1452.               GOTO 260
  1453.             ENDIF
  1454. c     passage Ni,qsi -> Ni,x
  1455.       dQsidX = 0.d0
  1456.       dQsidY = 0.d0
  1457.       if((abs(dXdQsi)).gt.XPETIT) dQsidX = 1.d0/dXdQsi
  1458.       if((abs(dYdQsi)).gt.XPETIT) dQsidY = 1.d0/dYdQsi
  1459.       IF(IDIM.EQ.3) THEN
  1460.         dQsidZ = 0.d0
  1461.         if(abs(dZdQsi).gt.XPETIT) dQsidZ = 1.d0/dZdQsi
  1462.       ENDIF
  1463.       CALL ZERO(BGR,NGRA,LRE)
  1464. c     on boucle sur les NGRA(=idim*idim) ligne :
  1465. c     IGRA2 permet de remplir 1 sur idim
  1466.       IGRA2=1
  1467.       DO  iidim = 1,idim
  1468. c         on boucle sur les idim*NBNO colonnes :
  1469. c         II permet de remplir 1 sur idim
  1470.           DO  I=1,NBNO
  1471.               II = idim*(I-1) + iidim
  1472.               BGR(IGRA2  ,II) = SHPWRK(2,I)*dQsidX
  1473.               BGR(IGRA2+1,II) = SHPWRK(2,I)*dQsidY
  1474.               if(idim.eq.3) BGR(IGRA2+2,II) = SHPWRK(2,I)*dQsidZ
  1475.           ENDDO
  1476.           IGRA2=IGRA2+idim
  1477.       ENDDO
  1478. c         {grad u}_i = [Bij] * {u_j}
  1479.           CALL BGRDEP(BGR,NGRA,XDDL,LRE,GRADI)
  1480. c         on remplit
  1481.           MPTVAL=IVAGRA
  1482.           DO i=1,NGRA
  1483.             MELVAL=IVAL(i)
  1484.             IGMN=MIN(iGau,VELCHE(/1))
  1485.             IBMN=MIN(IB,VELCHE(/2))
  1486.             VELCHE(IGMN,IBMN)=GRADI(i)
  1487.           ENDDO
  1488.  2660     CONTINUE
  1489.           GOTO 100
  1490.  
  1491. C= 4.14.267 - Element ZCO3
  1492.  267      CONTINUE
  1493.           IF (IB.EQ.1) SEGINI,MWRK2,MWRK4
  1494.           DO 2670 iGau=1,NBPGAU
  1495. C         MATRICE JACOBIENNE
  1496.           DO  I=1,NBNO
  1497.              SHPWRK(1,I) = SHPTOT(1,I,IGAU)
  1498.              SHPWRK(2,I) = SHPTOT(2,I,IGAU)
  1499.              SHPWRK(3,I) = SHPTOT(3,I,IGAU)
  1500.           ENDDO
  1501. c          write(6,*) 'SHPWRK(2,I) = ' ,(SHPWRK(2,iou),iou=1,NBNO)
  1502. c          write(6,*) 'SHPWRK(3,I) = ' ,(SHPWRK(3,iou),iou=1,NBNO)
  1503.  
  1504.  
  1505.           dXdQsi=0.D0
  1506.           dXdEta=0.D0
  1507.           dYdQsi=0.D0
  1508.           dYdEta=0.D0
  1509.           dZdQsi=0.D0
  1510.           dZdEta=0.D0
  1511.           DO i=1,NBNO
  1512.              dXdQsi=dXdQsi+SHPWRK(2,i)*XE(1,i)
  1513.              dXdEta=dXdEta+SHPWRK(3,i)*XE(1,i)
  1514.              dYdQsi=dYdQsi+SHPWRK(2,i)*XE(2,i)
  1515.              dYdEta=dYdEta+SHPWRK(3,i)*XE(2,i)
  1516.              dZdQsi=dYdQsi+SHPWRK(2,i)*XE(3,i)
  1517.              dZdEta=dZdEta+SHPWRK(3,i)*XE(3,i)
  1518.           ENDDO
  1519.  
  1520. c          write(6,*)' dXdQsi = ',dXdQsi
  1521. c          write(6,*)' dYdQsi = ',dYdQsi
  1522. c          write(6,*)' dZdQsi = ',dZdQsi
  1523. c          write(6,*)' dXdEta = ',dXdEta
  1524. c          write(6,*)' dYdEta = ',dYdEta
  1525. c          write(6,*)' dZdEta = ',dZdEta
  1526. C         definition des vecteurs de la base orthonormee
  1527. c         vQsi
  1528.           vQsi = sqrt(dXdQsi*dXdQsi+dYdQsi*dYdQsi+dZdQsi*dZdQsi)
  1529. c          write(6,*) 'Norme de vQsi = ',vQsi
  1530.           vQsiX = dXdQsi / vQsi
  1531.           vQsiY = dYdQsi / vQsi
  1532.           vQsiZ = dZdQsi / vQsi
  1533. c          write(6,*) ' vQsiX = ', vQsiX
  1534. c          write(6,*) ' vQsiY = ', vQsiY
  1535. c          write(6,*) ' vQsiZ = ', vQsiZ
  1536.  
  1537. c         produit scalaire VEta vQsi
  1538.           Sca1 = dXdEta*vQsiX + dYdEta*vQsiY + dZdEta*vQsiZ
  1539. c          write(6,*) 'VEta.vQsi = ',Sca1
  1540. c         EEta = Veta - sca1 Eqsi (orthogonalisation)
  1541.           vEtaX = dXdEta - sca1 * vQsiX
  1542.           vEtaY = dYdEta - sca1 * vQsiY
  1543.           vEtaZ = dZdEta - sca1 * vQsiZ
  1544. c          write(6,*) ' vEtaX = ', vEtaX
  1545. c          write(6,*) ' vEtaY = ', vEtaY
  1546. c          write(6,*) ' vEtaZ = ', vEtaZ
  1547. c         on morme EEta
  1548.           vEta = sqrt(vEtaX*vEtaX+vEtaY*vEtaY+vEtaZ*vEtaZ)
  1549. c          write(6,*) 'Norme de vEta = ',veta
  1550.           vEtaX = vEtaX / vEta
  1551.           vEtaY = vEtaY / vEta
  1552.           vEtaZ = vEtaZ / vEta
  1553.  
  1554. c         Qsi,x
  1555.           dQsidX=0.D0
  1556.           dQsidY=0.D0
  1557.           dQsidZ=0.D0
  1558.           dEtadX=0.D0
  1559.           dEtadY=0.D0
  1560.           dEtadZ=0.D0
  1561.           dQsidX=(vQsiX - (sca1*vEtaX)/vEta)/vQsi
  1562.           dQsidY=(vQsiY - (sca1*vEtaY)/vEta)/vQsi
  1563.           dQsidZ=(vQsiZ - (sca1*vEtaZ)/vEta)/vQsi
  1564.           dEtadX=vEtaX/vEta
  1565.           dEtadY=vEtaY/vEta
  1566.           dEtadZ=vEtaZ/vEta
  1567.  
  1568. c          write(6,*)' dQsidX = ',dQsidX
  1569. c          write(6,*)' dQsidY = ',dQsidY
  1570. c          write(6,*)' dQsidZ = ',dQsidZ
  1571. c          write(6,*)' dEtadX = ',dEtadX
  1572. c          write(6,*)' dEtadY = ',dEtadY
  1573. c          write(6,*)' dEtadZ = ',dEtadZ
  1574.  
  1575. c          write(6,*) 'SHPWRK(1,I) = ' ,(SHPWRK(1,iou),iou=1,NBNO)
  1576. c          write(6,*) 'SHPWRK(2,I) = ' ,(SHPWRK(2,iou),iou=1,NBNO)
  1577. c          write(6,*) 'SHPWRK(3,I) = ' ,(SHPWRK(3,iou),iou=1,NBNO)
  1578.  
  1579.           CALL ZERO(BGR,NGRA,LRE)
  1580. c     on boucle sur les NGRA(=idim*idim) ligne :
  1581. c     IGRA2 permet de remplir 1 sur idim
  1582.           IGRA2=1
  1583.           DO  iidim = 1,idim
  1584. c         on boucle sur les idim*NBNO colonnes :
  1585. c         II permet de remplir 1 sur idim
  1586.              DO  I=1,NBNO
  1587.                 II = idim*(I-1) + iidim
  1588.                 BGR(IGRA2  ,II) = SHPWRK(2,I)*dQsidX+SHPWRK(3,I)*dEtadX
  1589.                 BGR(IGRA2+1,II) = SHPWRK(2,I)*dQsidY+SHPWRK(3,I)*dEtadY
  1590.                 if(idim.eq.3) then
  1591.                  BGR(IGRA2+2,II) = SHPWRK(2,I)*dQsidZ+SHPWRK(3,I)*dEtadZ
  1592.                 endif
  1593.              ENDDO
  1594.              IGRA2=IGRA2+idim
  1595.           ENDDO
  1596. c         {grad u}_i = [Bij] * {u_j}
  1597. c          DO  I=1,NGRA
  1598. c          write(6,*) 'BGR(',I,',..) = ' ,(BGR(I,iou),iou=1,idim*NBNO)
  1599. c          write(6,*) 'BGR(2,I) = ' ,(BGR(2,iou),iou=1,idim*NBNO)
  1600. c          write(6,*) 'BGR(3,I) = ' ,(BGR(3,iou),iou=1,idim*NBNO)
  1601. c          ENDDO
  1602.  
  1603.           CALL BGRDEP(BGR,NGRA,XDDL,LRE,GRADI)
  1604. c          write(6,*) 'XDDL(i) = ' ,(XDDL(iou),iou=1,LRE)
  1605. c          write(6,*) 'GRADI(i) = ' ,(GRADI(iou),iou=1,NGRA)
  1606. c         on remplit
  1607.           MPTVAL=IVAGRA
  1608.           DO i=1,NGRA
  1609.             MELVAL=IVAL(i)
  1610.             IGMN=MIN(iGau,VELCHE(/1))
  1611.             IBMN=MIN(IB,VELCHE(/2))
  1612.             VELCHE(IGMN,IBMN)=GRADI(i)
  1613.           ENDDO
  1614.  
  1615.  2670     CONTINUE
  1616.           GOTO 100
  1617.  
  1618.  100    CONTINUE
  1619.  
  1620.         IF (ITHEHY.NE.0) SEGSUP,MLREE1,MLREE2
  1621. C= Fin de la boucle sur les elements
  1622.         iOK=1
  1623. C ======
  1624. C  2.15 - Desactivation/suppression de segments associes a iSou
  1625. C ======
  1626.  260    IF (MWRK2.NE.0) SEGSUP,MWRK2
  1627.         IF (MWRK3.NE.0) SEGSUP,MWRK3
  1628.         IF (MWRK4.NE.0) SEGSUP,MWRK4
  1629.         IF (MVELCH.NE.0) SEGSUP,MVELCH
  1630.  250    CONTINUE
  1631.         SEGSUP,MWRK1
  1632.         NOMID=MOGRAD
  1633.         if(lsupgd)SEGSUP,NOMID
  1634.  240    NOMID=MODEPL
  1635.         if(lsupdp)SEGSUP,NOMID
  1636.         IF(COMAUT) MODEPL=0
  1637.         IF(IVADEP .GT. 0) CALL DTMVAL(IVADEP,1)
  1638.  230    IF (MOMATR.NE.0) THEN
  1639.           NOMID=MOMATR
  1640.           SEGSUP,NOMID
  1641.         ENDIF
  1642.         IF(IVAMAT .GT. 0) CALL DTMVAL(IVAMAT,1)
  1643.  220    IF (MOCARA.NE.0) THEN
  1644.           NOMID=MOCARA
  1645.           SEGSUP,NOMID
  1646.         ENDIF
  1647.         IF(IVACAR .GT. 0) CALL DTMVAL(IVACAR,1)
  1648.  200    CONTINUE
  1649. C= Sortie prematuree en cas d'ERREUR (iOK=0)
  1650.         IF (iOK.EQ.0) THEN
  1651.           IF(IVAGRA .GT. 0) CALL DTMVAL(IVAGRA,3)
  1652.           IF (MCHAML.NE.0) SEGSUP,MCHAML
  1653.           SEGSUP,MCHELM
  1654.           IF (iMess.NE.0) THEN
  1655.             INTERR(1)=IB
  1656.             CALL ERREUR(iMess)
  1657.           ENDIF
  1658.           GOTO 300
  1659.         ENDIF
  1660.         MPTVAL = IVAGRA
  1661.         DO i = 1, IVAL(/1)
  1662.           MELVAL = IVAL(i)
  1663.           CALL COMRED(MELVAL)
  1664.           IVAL(i)=MELVAL
  1665.         ENDDO
  1666.         IF(IVAGRA .GT. 0) CALL DTMVAL(IVAGRA,1)
  1667.  2000 continue
  1668.  
  1669. C  3 - MENAGE : DESACTIVATION/DESTRUCTION DE SEGMENTS
  1670. C ====================================================
  1671.       IRET=1
  1672.       if (n1.ne.isouss) then
  1673.         n1=isouss
  1674.         segadj mchelm
  1675.       endif
  1676.  300  CONTINUE
  1677.       NOTYPE=MOTYCH
  1678.       SEGSUP,NOTYPE
  1679.  
  1680.       RETURN
  1681.       END
  1682.  
  1683.  
  1684.  
  1685.  
  1686.  
  1687.  

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