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

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