Télécharger la plaquette Cast3M


fr en

Télécharger grad1.eso

Retour à la liste

Numérotation des lignes : 

grad1

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

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