Sources Esope | Cast3M

kmec
C KMEC      SOURCE    CB215821  20/11/25    13:31:32     10792          
      SUBROUTINE KMEC(MTABP,MATRAK)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C************************************************************************
C    Operateur KMEC
C
C    OBJET   : Cree un objet de type MATRAK
C    APPELE PAR KMAC
C    SYNTAXE : RESU = KMAC RVP &lt;IMPR> ;
C
C    RVP  : TABLE de soustype EQPR  (cree par EQPR)
C    IMPR : impression du contenu de l'objet'
C
C    REMARQUE : Cet objet n'est pas un objet STANDART CASTEM2000
C               Il n'est donc pas listable
C    Il est tout juste bon a mettre dans la table RVP pour etre utilise
C    par les operateurs de résolution de la matrice de contrainte
C***********************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
      POINTEUR IZCH2.MCHPOI,IZCCH2.MPOVAL
      POINTEUR IZDV.MCHPOI,IZDDV.MPOVAL
C-INC SMMATRAKANC
C*************************************************************************
C
C    REPERAGE ET STOKAGE DES MATRICES ELEMENTAIRES  puis assemblees
C
 
* LGEOC SPG de la pression et/ou des multiplicateurs de Lagrange
* (points CENTRE ) pour chaque operateur de contrainte
* KGEOC SPG pour la totalite des points CENTRE.
* KGEOS SPG pour la totalite des points SOMMET (Diagonale vitesse)
* KLEMC Connectivites de l'ensemble des contraintes
* LIZAFM(NBSOUS) contient les pointeurs IZAFM des sous-zones
 
      SEGMENT MATRAK
      INTEGER LGEOC(NBOP),IDEBS(NBOP),IFINS(NBOP)
      INTEGER LIZAFM(NBSOUS)
      INTEGER IKAM0 (NBSOUS)
      INTEGER IMEM  (NBELC)
      INTEGER KLEMC,KGEOS,KGEOC,KDIAG,KCAC,KIZCL,KIZGC
      ENDSEGMENT
 
      SEGMENT IZAFM
      REAL*8  AM(NNELP,NP,IESP),RPGI(NELAX)
      ENDSEGMENT
 
      POINTEUR IPMJ.IZAFM,IPMK.IZAFM
 
C*******************************************************************
-INC SMLENTI
      POINTEUR IZIPAD.MLENTI
-INC SMLMOTS
-INC SMTABLE
      POINTEUR MTABP.MTABLE,MTABX.MTABLE,MTABZ.MTABLE
-INC SMELEME
      POINTEUR MELEMZ.MELEME,MELEMB.MELEME
      POINTEUR MELEM1.MELEME,MELES1.MELEME
      POINTEUR IGEOM.MELEME
      POINTEUR IZLEMC.MELEME
 
      LOGICAL*1 BVAL,VRAI
      PARAMETER (NBOPER=4)
      CHARACTER*8 LIOPER(NBOPER),TYPE,TYPC,NOML,NOMO,NOM,LMOT(1)
C
      DATA LIOPER/'PRESSIO ','VNIMP   ','VTIMP   ','DPDQ    '/
C***
      IMPR=0
      TYPE=' '
      CALL ACMO(MTABP,'LISTOPER',TYPE,MLMOTS)
      IF(TYPE.NE.'LISTMOTS')THEN
      RETURN
      ENDIF
      SEGACT MLMOTS
      NBOP=MOTS(/2)
 
      IZLEMC=0
      NBSOUS=0
      NBELC=0
      KM=1
      KMS=1
      SEGINI MATRAK
 
      DO 1 M=1,NBOP
 
      NOML=MOTS(M)
      TYPE=' '
      CALL ACMO(MTABP,NOML,TYPE,MTABX)
      IF(TYPE.NE.'TABLE   ')GO TO 90
      SEGACT MTABX
      TYPE=' '
      CALL ACMO(MTABX,'DOMZ',TYPE,MTABZ)
      IF(TYPE.NE.'TABLE   ')GO TO 90
      SEGACT MTABZ
      TYPE=' '
      CALL ACMO(MTABZ,'CENTRE',TYPE,MELEM1)
      IF(TYPE.NE.'MAILLAGE')GO TO 90
 
      IF(M.LT.10)THEN
      NOMO=MOTS(M)(2:8)
      ELSE
      NOMO=MOTS(M)(3:8)
      ENDIF
      CALL OPTLI(IP,LIOPER,NOMO,NBOPER)
C     write(6,*)' NOMO=',NOMO,':',' IP=',IP
      IF(IP.EQ.0)THEN
      WRITE(6,*)' Operateur : ',NOMO,' inconnu '
      RETURN
      ENDIF
 
      IAXI = 0
      IF(IFOMOD.EQ.0)IAXI=2
 
C On va chercher ou on construit MELEMZ et MELEMB
 
 
      TYPE=' '
      CALL ACMO(MTABZ,'MAILLAGE',TYPE,MELEMZ)
      IF(TYPE.NE.'MAILLAGE')GO TO 90
      CALL KNBEL(MELEMZ,NBELCN)
 
C pour MELEMB c'est plus complique
 
      LGEOC(M)=MELEM1
 
      IF(IP.EQ.2.OR.IP.EQ.3)THEN
      CALL ECRCHA('POI1')
      CALL ECROBJ('MAILLAGE',MELEMZ)
      CALL PRCHAN
      TYPE='MAILLAGE'
      CALL LIROBJ(TYPE,MELES1,1,IRET)
      IF(IRET.EQ.0)GO TO 90
      SEGACT MELES1
      IF(IRET.EQ.0)GO TO 90
      CALL KAMLPT(MELES1,MELEMZ,IRET)
      SEGDES MELES1
      MELEMZ=IRET
      SEGACT MELEMZ
      NBPZ=MELEMZ.NUM(/2)
      NBREF=MELEMZ.LISREF(/1)
      MELEMB=MELEMZ.LISREF(NBREF)
      LGEOC(M)=MELEMB
C il semble que la numerotation soit meilleure sans l'appel de ORDOTA
C au moins pour l'utilisation de VNSIMP et VTSIMP avec des CHPOINTs
C      CALL ORDOTA(MELEMZ.NUM,NBPZ)
      CALL KRIPAD(MELEMZ,IZIPAD)
 
      TYPE='CENTRE'
      CALL CRCHPT(TYPE,MELEMB,1,IZCH2)
      CALL ECMO(MTABX,'IZCH2','CHPOINT ',IZCH2)
      CALL LICHT(IZCH2,IZCCH2,TYPE,IGEOM)
 
      ENDIF
 
C La on peut dire qu'on a MELEMZ et MELEMB
 
      MELEMB=LGEOC(M)
      SEGACT MELEMB
      NNELB=MELEMB.NUM(/2)
      IDEBS(M)=KMS
      IFINS(M)=KMS+NNELB-1
      KMS=KMS+NNELB
      SEGDES MELEMB
 
      CALL CATMEL(IZLEMC,MELEMZ)
 
      SEGACT MELEMZ
      NBSOUZ=MELEMZ.LISOUS(/1)
      IF(NBSOUZ.EQ.0)NBSOUZ=1
      NBSOU0=LIZAFM(/1)
      NBSOUS=NBSOU0+NBSOUZ
      NBELC=IMEM(/1)
      SEGADJ MATRAK
 
      DO 11 L=1,NBSOUZ
      IPT1=MELEMZ
      IF(NBSOUZ.NE.1)IPT1=MELEMZ.LISOUS(L)
      SEGACT IPT1
      NNELP=IPT1.NUM(/2)
      NELAX=0
      NP=IPT1.NUM(/1)
      IESP=IDIM
      NBELC0=IMEM(/1)
      NBELC=NBELC0+NNELP
      SEGADJ MATRAK
 
      CALL INITI(IMEM(KM),NNELP,NBSOU0+L)
      SEGINI IZAFM
      KAM0=KM
      LIZAFM(NBSOU0+L)=IZAFM
      IKAM0 (NBSOU0+L)=KAM0
C     write(6,*)' KAS kmac IP=',IP
 
      GO TO (10,20,30,40),IP
 10   CONTINUE
C     write(6,*)' Appel a KPRESS'
      CALL KPRESS(IPT1,IZAFM,IAXI,IMPR)
C     write(6,*)' Retour de KPRESS '
      GO TO 9
 20   CONTINUE
 
C     write(6,*)' Appel a VNSIMP'
      CALL VNSIMP(IPT1,IZAFM,IZCCH2,IZIPAD)
C     write(6,*)' Retour de VNSIMP'
      SEGDES IZCH2,IZCCH2
      SEGSUP IZIPAD
      GO TO 9
 30   CONTINUE
 
      CALL VTSIMP(IPT1,IZAFM,IZCCH2,IZIPAD)
      SEGDES IZCH2,IZCCH2
      SEGSUP IZIPAD
      GO TO 9
 
 40   CONTINUE
 
C     CALL KDPDQ(IPT1,IZAFM,HK,IAXI,IMPR)
C     SEGDES IZCH2,IZCCH2
C     SEGSUP IZIPAD
      write(6,*)' Operateur hors service '
      GO TO 9
 
 9    CONTINUE
 
      SEGDES IZAFM
      SEGDES IPT1
      KM=KM+NNELP
 11   CONTINUE
      SEGDES MELEMZ
      SEGDES MTABX,MTABZ
 
 1    CONTINUE
 
      IGEO1=LGEOC(1)
 
      IF(NBOP.GT.1)THEN
      IGEO1=0
      DO 2 M=1,NBOP
      MLGEOC=LGEOC(M)
      CALL FUSSPG(MLGEOC,IGEO1)
 2    CONTINUE
      ENDIF
 
      KGEOC=IGEO1
 
      KLEMC=IZLEMC
 
      TYPE=' '
      CALL ACMO(MTABP,'DIAGV',TYPE,IZDV)
      IF(TYPE.NE.'CHPOINT')THEN
      WRITE(6,*)' l''entree DIAGV n''existe pas dans la table EQPR'
      RETURN
      ENDIF
      CALL LICHT(IZDV,IZDDV,TYPC,IGEOM)
      SEGDES IZDV,IZDDV
 
      INK=1
      CALL KRIPAD(IGEOM,IZIPAD)
      NBPT=IZIPAD.LECT(/1)
      SEGACT IZLEMC
      NBSOUS=IZLEMC.LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1
      DO 401 L=1,NBSOUS
      IPT1=IZLEMC
      IF(NBSOUS.NE.1)IPT1=IZLEMC.LISOUS(L)
      SEGACT IPT1
      NP=IPT1.NUM(/1)
      NEL=IPT1.NUM(/2)
      MLENTI=IZIPAD
      DO 402 K=1,NEL
      DO 402 I=1,NP
      j=IPT1.NUM(I,K)
      IF(LECT(J).EQ.0)THEN
      INK=0
C     write(6,*)' Objet non inclus '
      return
      endif
 402  CONTINUE
      SEGDES IPT1
 401  CONTINUE
      SEGDES IZLEMC
      SEGSUP IZIPAD
 
      KGEOS=IGEOM
 
      SEGDES MLMOTS
      SEGDES MATRAK
      RETURN
 90   CONTINUE
      MATRAK=0
      RETURN
 1001 FORMAT(20(1X,I5))
      END