1 : C KKDOM2 SOURCE CHAT 05/01/13 00:56:44 5004 2 : C KKDOM SOURCE MAGN 02/10/07 21:15:19 4439 3 : SUBROUTINE KKDOM2(MELEME,TOLER,NOMDOM,MTABI,MTABD,INEFMD) 4 : C************************************************************************ 5 : C 6 : C OBJET : Cree une table de soustype DOMAINE 7 : C Appele par KDOM 8 : C 9 : C************************************************************************ 10 : IMPLICIT INTEGER(I-N) 11 : IMPLICIT REAL*8 (A-H,O-Z) 12 : CHARACTER*8 NOMDOM,NOMC 13 : CHARACTER*8 NOM,TYPE,TYPI 14 : PARAMETER (NMEL=8) 15 : DIMENSION SGA(NMEL),SEPS(NMEL),SEPSD(NMEL) 16 : C*** 17 : -INC CCOPTIO 18 : -INC SMELEME 19 : POINTEUR MELEMS.MELEME,MELEMC.MELEME,MELEF1.MELEME,MELEMP.MELEME 20 : POINTEUR MFF2.MELEME 21 : -INC SMLENTI 22 : DATA SGA/1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0/ 23 : DATA SEPS/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0/ 24 : DATA SEPSD/8*0.D0/ 25 : C*** 26 : 27 : C On verifie que si la directive INCL est présente les SPG 28 : C des points sommets sont bien inclus 29 : 30 : MELEP0=0 31 : C write(6,*)' DEBUT KKDOM ========================' 32 : IF(MTABI.NE.0)THEN 33 : TYPI='MAILLAGE' 33 : CALL ACMO(MTABI,'SOMMET',TYPI,MSI) 33 : CALL KRIPAD(MSI,MLENTI) 33 : CALL VERPAD(MLENTI,MELEME,IRET) 34 : IF(IRET.NE.0)THEN 35 : WRITE(6,*)' Opérateur DOMA ' 36 : WRITE(6,*)' Le maillage n''est pas contenu dans celui de' 37 : & ,' la table donnée pour la directive INCL ' 38 : RETURN 39 : ENDIF 40 : SEGSUP MLENTI 41 : ENDIF 42 : 42 : C??? call CQF2LN(MELEME,MLINE) 42 : CALL KQCEST(MELEME,IKR) 43 : 44 : IF(IKR.EQ.1341)IKR=1 45 : IF(IKR.EQ.13)IKR=1 46 : 47 : IF(IKR.EQ.2)THEN 48 : C au depart des LINEs -> LINE 49 : C write(6,*)'au depart des LINEs -> LINE' 50 : 50 : CALL ECROBJ('MAILLAGE',MELEME) 50 : CALL CHANQU 50 : CALL C20227 51 : IF (IERR.NE.0) RETURN 51 : CALL LIROBJ('MAILLAGE',MELEME,1,IRET) 52 : MAIL=MELEME 52 : CALL CQF2LN(MELEME,MLINE) 53 : C write(6,*)' AVT TQ2CF' 54 : NOMC=' ' 54 : CALL TQ2CF(MAIL,MELEMQ,MELEMC, 55 : & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR) 56 : MELEME=MLINE 57 : ELSEIF(IKR.EQ.1.AND.INEFMD.EQ.1)THEN 58 : C au depart des QUAFs -> LINE 59 : C write(6,*)'au depart des QUAFs -> LINE ' 60 : 61 : MAIL=MELEME 62 : C write(6,*)' KKDOM QUAFs -> LINE' 63 : NOMC=' ' 63 : CALL TQ2CF(MAIL,MELEMQ,MELEMC, 64 : & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR) 64 : CALL CQF2LN(MELEME,MLINE) 65 : MELEME=MLINE 66 : C? MELEME=MAIL 67 : ENDIF 68 : 69 : C write(6,*)' APR MTABI=',mtabi 69 : CALL CRTABL(MTABD) 69 : CALL ECMM(MTABD,'SOUSTYPE','DOMAINE') 69 : CALL ECME(MTABD,'PRECONDI',1) 70 : C write(6,*)' QUAF MELEMQ=',MELEMQ 70 : C? call ecrobj('MAILLAGE',MELEMQ) 70 : C? call prlist 70 : CALL ECMO(MTABD,'QUAF','MAILLAGE',MELEMQ) 70 : IF(MTABI.NE.0) CALL ECMO(MTABD,'PERE','TABLE',MTABI) 70 : CALL ECMM(MTABD,'NOMDOM',NOMDOM) 70 : CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEME) 70 : CALL ECME(MTABD,'INEFMD',INEFMD) 71 : 72 : C write(6,*)' MELEF1,MELEMF,MELEMP,MELEMC,MELAF=', 73 : C &MELEF1,MELEMF,MELEMP,MELEMC,MELAF 73 : CALL ECMO(MTABD,'FACE','MAILLAGE',MELEF1) 73 : CALL ECMO(MTABD,'FACEL','MAILLAGE',MELEMF) 73 : CALL ECMO(MTABD,'FACEP','MAILLAGE',MELEMP) 73 : CALL ECMO(MTABD,'CENTRE','MAILLAGE',MELEMC) 73 : CALL ECMO(MTABD,'ELTFA','MAILLAGE',MELAF) 73 : CALL ECMO(MTABD,'FACEL2','MAILLAGE',MELEF2) 73 : CALL ECMO(MTABD,'MAILFACE','MAILLAGE',MFF2) 73 : CALL ECMF(MTABD,'TOLER',TOLER) 74 : 74 : C? CALL ECRCHA('POI1') 74 : C? CALL ECROBJ('MAILLAGE',MELEME) 74 : C? CALL ECROBJ('MAILLAGE',MAIL ) 74 : C? CALL PRCHAN 74 : C? CALL LIROBJ('MAILLAGE',MELEMS,1,IRET) 75 : C? IF(IRET.EQ.0)RETURN 75 : CALL CM2PO1(MELEME,MELEMS) 75 : CALL ECMO(MTABD,'SOMMET','MAILLAGE',MELEMS) 76 : C???? IF(MELEMS.EQ.0)RETURN 77 : 78 : C write(6,*)' MTABI=',mtabi,' retour si 0 ' 79 : IF(MTABI.NE.0)THEN 80 : 81 : C In CRTABL -> SEGINI MTBT0 81 : CALL CRTABL(MTBT0) 81 : CALL ECME(MTBT0,'PRECONDI',1) 81 : CALL NOMOBJ('TABLE','tabl0tmp',MTBT0) 82 : 82 : CALL ECMO(MTBT0,'QUAF','MAILLAGE',MELEMQ) 82 : CALL ECMO(MTBT0,'SOMMET','MAILLAGE',MELEMS) 82 : CALL ECMO(MTBT0,'FACE ','MAILLAGE',MELEF1) 82 : CALL ECMO(MTBT0,'FACEL','MAILLAGE',MELEMF) 82 : CALL ECMO(MTBT0,'FACEP','MAILLAGE',MELEMP) 82 : CALL ECMO(MTBT0,'CENTRE','MAILLAGE',MELEMC) 82 : CALL ECMO(MTBT0,'ELTFA','MAILLAGE',MELAF) 82 : CALL ECMO(MTBT0,'FACEL2','MAILLAGE',MELEF2) 82 : CALL ECMO(MTBT0,'MAILFACE','MAILLAGE',MFF2) 82 : CALL ECMO(MTBT0,'MAILLAGE','MAILLAGE',MELEME) 83 : 84 : C write(6,*)' On vérifie l inclusion des points sommets ' 85 : C On vérifie l'inclusion des points sommets (on peut avoir créé des pts centre) 86 : TYPI='MAILLAGE' 86 : CALL ACMO(MTABI,'SOMMET',TYPI,MSI) 86 : CALL ACMO(MTABI,'FACE',TYPI,MFI) 86 : CALL ACMO(MTABI,'CENTRE',TYPI,MCI) 86 : CALL ECROBJ('MAILLAGE',MFI) 86 : CALL ECROBJ('MAILLAGE',MCI) 86 : CALL PRFUSE 86 : CALL ECROBJ('MAILLAGE',MSI) 86 : CALL PRFUSE 86 : CALL ECROBJ('MAILLAGE',MELEMS) 86 : CALL PRFUSE 86 : CALL ECROBJ('MAILLAGE',MELEF1) 86 : CALL PRFUSE 86 : CALL ECROBJ('MAILLAGE',MELEMC) 86 : CALL PRFUSE 86 : CALL ECRREE(TOLER) 86 : CALL PRELIM(0) 86 : CALL LIROBJ('MAILLAGE',MMMMM,1,IRET) 87 : ENDIF 88 : C write(6,*)' APRES verification ' 89 : 90 : SEGACT MELEF1 91 : NBFD=MELEF1.NUM(/2) 92 : SEGDES MELEF1 93 : SEGACT MELEMC 94 : NELD=MELEMC.NUM(/2) 95 : SEGDES MELEMC 96 : SEGACT MELEMS 97 : NPTD=MELEMS.NUM(/2) 98 : SEGDES MELEMS 99 : 99 : CALL ECME(MTABD,'NPTD',NPTD) 99 : CALL ECME(MTABD,'NELD',NELD) 99 : CALL ECME(MTABD,'NBFD',NBFD) 100 : 101 : C write(6,*)' Appel a REFE' 101 : CALL ECROBJ('MAILLAGE',MELEME) 101 : CALL REFE 101 : CALL LIROBJ('LISTMOTS',ITABOG,0,IRET) 101 : CALL ECMO(MTABD,'OBJINCLU','LISTMOTS',ITABOG) 102 : C write(6,*)' FIN KKDOM ********************** ' 103 : 104 : RETURN 105 : END 106 : 107 : 108 : 109 :
© Cast3M 2003 - All rights reserved.
Disclaimer