Sources Esope | Cast3M

kgra
C KGRA      SOURCE    GOUNAND   25/11/12    21:15:22     12399          
      SUBROUTINE KGRA(MCHPO1,MPOVA1,IGEOM1,MTABD)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C*************************************************************************
C     Operateur KGRA
C
C     Objet : determine le GRADIENT  d un CHAMPOINT SOMMET
C
C     SYNTAXE : CHGR =KOPS CHPS 'GRAD' TABDOM ;
C     TABDOM  : Table DOMAINE contenant le support geometrique de CHPC
C     CHPS    : CHAMPOINT SOMMET
C     CHGR    : CHAMPOINT CENTRE
C
C*************************************************************************
-INC SMTABLE
      POINTEUR MTABD.MTABLE
-INC SMELEME
      POINTEUR MELEMS.MELEME,MELEMC.MELEME,IGEOM1.MELEME
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC CCGEOME
-INC SMCHPOI
      POINTEUR IZB.MCHPOI,IZBB.MPOVAL
      POINTEUR IZD.MCHPOI,IZDD.MPOVAL
      POINTEUR IZV.MCHPOI,IZVV.MPOVAL
-INC SMLENTI
      POINTEUR IZIPAD.MLENTI
-INC SIZFFB
      REAL*8 HRT(24),RPGJ(9),XYZI(8)
      CHARACTER*8 TYPE,TYPC,NOM0
C***
C     write(6,*)' On est dans KGRA '
      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2
 
      NC=MPOVA1.VPOCHA(/2)
 
      IF(NC.NE.1)THEN
      WRITE(6,*)' Opérateur KOPS option GRAD '
      WRITE(6,*)' Le Champoint a plus d''une composante ',nc
      RETURN
      ENDIF
 
      TYPE=' '
      CALL ACMO(MTABD,'SOMMET',TYPE,MELEMS)
 
      CALL KRIPAD(IGEOM1,IZIPAD)
        CALL VERPAD(IZIPAD,MELEMS,IRET)
         IF(IRET.NE.0)THEN
C%    Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique
          MOTERR(1: 8) = 'TETA1'
          MOTERR(9:16) = 'CHPOINT '
          WRITE(IOIMP,*)'Operateur : KOPS GRAD'
          CALL ERREUR(788)
          RETURN
         ENDIF
 
      TYPE=' '
      CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
      TYPE='CENTRE'
      CALL CRCHPT(TYPE,MELEMC,IDIM,1,MCHPOI)
      CALL LICHTM(MCHPOI,MPOVAL,TYPE,IGEOM)
 
      TYPE=' '
      CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
 
      SEGACT MELEME
      NBSOUS=LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1
 
      KK=0
      DO 1 L=1,NBSOUS
      IPT1=MELEME
      IF(NBSOUS.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      NP=IPT1.NUM(/1)
      NEL=IPT1.NUM(/2)
 
      NOM0=NOMS(IPT1.ITYPEL)//'    '
      CALL KALPBG(NOM0,'FONFORM0',IZFFM)
      IF(IZFFM.EQ.0)GO TO 90
      SEGACT IZFFM*MOD
      IZHR=KZHR(1)
      SEGACT IZHR*MOD
      NPG=FN(/2)
      NES=GR(/1)
 
      DO 10 K=1,NEL
      KK=KK+1
      DO 9 I=1,NP
      J=IPT1.NUM(I,K)
      DO 12 N=1,IDIM
      XYZ(N,I)=XCOOR((J-1)*(IDIM+1)    +N)
 12   CONTINUE
 9    CONTINUE
 
      CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,
     *IDIM,NP,NPG,IAXI,AIRE)
 
      DO 36 N=1,IDIM
      UU=0.D0
      DO 35 I=1,NP
      IU = IZIPAD.LECT(IPT1.NUM(I,K))
      UU= UU + MPOVA1.VPOCHA(IU,1)*HR(N,I,1)
   35 CONTINUE
      VPOCHA(KK,N)=UU
   36 CONTINUE
 
 10   CONTINUE
      SEGDES IPT1
 1    CONTINUE
      SEGDES MPOVA1,MPOVAL
      SEGDES MCHPO1,MCHPOI
      SEGDES MELEME,IGEOM1,MELEMS
C
      SEGSUP IZIPAD,IZFFM,IZHR
      CALL ECROBJ('CHPOINT ',MCHPOI)
 
      RETURN
 
 90   CONTINUE
      WRITE(6,*)'Interruption anormale de KOPS option GRAD '
      RETURN
 
 1001 FORMAT(20(1X,I5))
 1008 FORMAT(10(1X,A8))
 1002 FORMAT(10(1X,1PE11.4))
      END