Sources Esope | Cast3M

kgras
C KGRAS     SOURCE    CB215821  23/01/25    21:15:25     11573          
      SUBROUTINE KGRAS(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,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***
 
      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2
 
      NC=MPOVA1.VPOCHA(/2)
      NPT=MPOVA1.VPOCHA(/1)
 
      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 GRADS'
          CALL ERREUR(788)
          RETURN
         ENDIF
 
      CALL LEKTAB(MTABD,'XXDIAGSI',MCHPO2)
      CALL LICHTL(MCHPO2,MPOVA2,TYPE,IGEOM)
      CALL KRIPAD(MELEMS,MLENT2)
      TYPE='SOMMET'
      CALL CRCHPT(TYPE,MELEMS,IDIM,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,'FONFORM ',IZFFM)
      IF(IZFFM.EQ.0)GO TO 90
      SEGACT IZFFM*MOD
      IZHR=KZHR(1)
      SEGACT IZHR*MOD
      NPG=FN(/2)
      NES=GR(/1)
 
      SEGACT,MCOORD
      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 35 I=1,NP
        I2 = MLENT2.LECT(IPT1.NUM(I,K))
 
        DO 36 N=1,IDIM
        UU=0.D0
        DO 37 LG=1,NPG
         GNUL=0.D0
         DO 38 J=1,NP
         J1 = IZIPAD.LECT(IPT1.NUM(J,K))
         GNUL = GNUL + MPOVA1.VPOCHA(J1,1)*HR(N,J,LG)
   38    CONTINUE
        UU= UU + FN(I,LG)*PGSQ(LG)*GNUL
   37   CONTINUE
        VPOCHA(I2,N)=VPOCHA(I2,N)+UU
   36   CONTINUE
   35   CONTINUE
 
 10   CONTINUE
 
 1    CONTINUE
      NPT=VPOCHA(/1)
      DO 2 I=1,NPT
      DO 2 N=1,IDIM
      VPOCHA(I,N)=VPOCHA(I,N)/MPOVA2.VPOCHA(I,1)
 2    CONTINUE
C
      SEGSUP IZIPAD,IZFFM,IZHR,MLENT2
      CALL ACTOBJ('CHPOINT ',MCHPOI,1)
      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