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

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