Sources Esope | Cast3M

krot
C KROT      SOURCE    CB215821  20/11/25    13:33:08     10792          
      SUBROUTINE KROT(MCHPO1,MPOVA1,IGEOM1,MTABD)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C*************************************************************************
C     Operateur KROT
C
C     Objet : determine le ROTATIONNEL d'un CHAMPOINT VECT SOMMET
C
C     SYNTAXE : CHGR =KOPS CHPS 'ROT' TABDOM ;
C     TABDOM  : Table DOMAINE contenant le support geometrique de CHPC
C     CHPS    : CHAMPOINT SOMMET
C     CHGR    : CHAMPOINT CENTRE
C
C*************************************************************************
C Correction FD : Le signe est faux en repère cartésien
C                 Ajout dans GIBI.ERREUR des messages 980 et 981
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***
      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2
 
      NC=MPOVA1.VPOCHA(/2)
      NPT=MPOVA1.VPOCHA(/1)
      IF(NC.NE.IDIM)THEN
C%    L'objet %m1:8 n'a pas le bon nombre de composantes
          MOTERR(1: 8) = 'CHPOINT '
          CALL ERREUR(980)
          RETURN
      ENDIF
 
      TYPE=' '
      CALL ACMO(MTABD,'SOMMET',TYPE,MELEMS)
 
      CALL KRIPAD(IGEOM1,IZIPAD)
      CALL VERPAD(IZIPAD,MELEMS,IRET)
      IF(IRET.NE.0)THEN
C%    L'object %m1:8 n'a pas le bon support géométrique
          MOTERR(1: 8) = 'CHPOINT '
          CALL ERREUR(981)
          RETURN
      ENDIF
 
      TYPE=' '
      CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
      TYPE='CENTRE'
      NC=IDIM
      IF(IDIM.EQ.2)NC=1
      CALL CRCHPT(TYPE,MELEMC,NC,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)
 
      IF(IDIM.EQ.2)THEN
        UU=0.D0
        DO 35 I=1,NP
           IU = IZIPAD.LECT(IPT1.NUM(I,K))
           UU = UU - ( MPOVA1.VPOCHA(IU,1)*HR(2,I,1) -
     &                 MPOVA1.VPOCHA(IU,2)*HR(1,I,1) )
   35   CONTINUE
        IF (IAXI.EQ.0) THEN
           VPOCHA(KK,1)= UU
        ELSE
           VPOCHA(KK,1)=-UU
        ENDIF
      ELSE
        UX=0.D0
        UY=0.D0
        UZ=0.D0
        DO 36 I=1,NP
           IU = IZIPAD.LECT(IPT1.NUM(I,K))
           UX= UX - ( MPOVA1.VPOCHA(IU,2)*HR(3,I,1) -
     &                MPOVA1.VPOCHA(IU,3)*HR(2,I,1) )
           UY= UY - ( MPOVA1.VPOCHA(IU,3)*HR(1,I,1) -
     &                MPOVA1.VPOCHA(IU,1)*HR(3,I,1) )
           UZ= UZ - ( MPOVA1.VPOCHA(IU,1)*HR(2,I,1) -
     &                MPOVA1.VPOCHA(IU,2)*HR(1,I,1) )
   36   CONTINUE
        VPOCHA(KK,1)=UX
        VPOCHA(KK,2)=UY
        VPOCHA(KK,3)=UZ
      ENDIF
 
 10   CONTINUE
 1    CONTINUE
C
      SEGSUP IZIPAD,IZFFM,IZHR
      CALL ACTOBJ('CHPOINT ',MCHPOI,1)
      CALL ECROBJ('CHPOINT ',MCHPOI)
 
      RETURN
 
 90   CONTINUE
      WRITE(IOIMP,*)'Interruption anormale de KOPS option GRAD '
      CALL ERREUR(5)
      RETURN
 
 1001 FORMAT(20(1X,I5))
 1008 FORMAT(10(1X,A8))
 1002 FORMAT(10(1X,1PE11.4))
      END