C KMEC SOURCE GOUNAND 25/11/12 21:15:25 12399 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 ; 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,2,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 4021 I=1,NP j=IPT1.NUM(I,K) IF(LECT(J).EQ.0)THEN INK=0 C write(6,*)' Objet non inclus ' return endif 4021 CONTINUE 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