1 : C KKDOM SOURCE MAGN 07/06/02 21:15:11 5749 2 : SUBROUTINE KKDOM(MELEME,MACRO,TOLER,NOMDOM,MTABI,MTABD,INEFMD) 3 : C************************************************************************ 4 : C 5 : C OBJET : Cree une table de soustype DOMAINE 6 : C Appele par KDOM 7 : C 8 : C************************************************************************ 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8 (A-H,O-Z) 11 : CHARACTER*8 NOMDOM,NOMC 12 : CHARACTER*8 NOM,TYPE,TYPI 13 : PARAMETER (NMEL=8) 14 : DIMENSION SGA(NMEL),SEPS(NMEL),SEPSD(NMEL) 15 : C*** 16 : -INC CCOPTIO 17 : -INC SMELEME 18 : POINTEUR MELEMS.MELEME,MELEMC.MELEME,MELEF1.MELEME,MELEMP.MELEME 19 : POINTEUR MFF2.MELEME 20 : -INC SMLENTI 21 : DATA SGA/1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0/ 22 : DATA SEPS/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0/ 23 : DATA SEPSD/8*0.D0/ 24 : C*** 25 : 26 : C On verifie que si la directive INCL est présente les SPG 27 : C des points sommets sont bien inclus 28 : 29 : MELEP0=0 30 : C write(6,*)' DEBUT KKDOM ========================' 31 : IF(MTABI.NE.0)THEN 32 : TYPI='MAILLAGE' 32 : CALL ACMO(MTABI,'SOMMET',TYPI,MSI) 32 : CALL KRIPAD(MSI,MLENTI) 32 : CALL VERPAD(MLENTI,MELEME,IRET) 33 : IF(IRET.NE.0)THEN 34 : WRITE(6,*)' Opérateur DOMA ' 35 : WRITE(6,*)' Le maillage n''est pas contenu dans celui de' 36 : & ,' la table donnée pour la directive INCL ' 37 : RETURN 38 : ENDIF 39 : SEGSUP MLENTI 40 : ENDIF 41 : 41 : C??? call CQF2LN(MELEME,MLINE) 41 : CALL KQCEST(MELEME,IKR) 42 : C write(6,*)' IKR=',IKR,' MACRO=',MACRO,' INEFMD=',INEFMD 43 : 44 : C? IF(IKR.EQ.13.AND.MACRO.NE.0)IKR=1 45 : C? IF(IKR.EQ.134.AND.MACRO.NE.0)IKR=1 46 : IF(IKR.EQ.13.AND.MACRO.NE.0)IKR=4 47 : IF(IKR.EQ.134.AND.MACRO.NE.0)IKR=4 48 : IF(IKR.EQ.34.AND.MACRO.NE.0)IKR=3 49 : IF(IKR.EQ.1341.AND.MACRO.EQ.0)IKR=1 50 : IF(IKR.EQ.13.AND.MACRO.EQ.0)IKR=1 51 : 52 : IF(IKR.EQ.1341.AND.MACRO.NE.0)THEN 53 : C au depart des SEG3 -> LINE -> MACRO 54 : C write(6,*)'au depart des SEG3 -> LINE -> MACRO' 55 : 56 : MACRO =MELEME 57 : MACRO1=MELEME 57 : CALL ECROBJ('MAILLAGE',MELEME) 57 : CALL CQ2L 57 : CALL LIROBJ('MAILLAGE',MLINE,1,IRET) 58 : MELEME=MLINE 59 : MAIL=MLINE 60 : NOMC=' ' 60 : CALL TQ2CF(MAIL,MELEMQ,MELEMC, 61 : & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR) 62 : IQUAD=0 63 : 64 : ELSEIF(IKR.EQ.1.AND.MACRO.EQ.0.AND.INEFMD.EQ.4)THEN 65 : C au depart des QUAFs -> LINB 66 : C write(6,*)'au depart des QUAFs -> LINB' 67 : 68 : MAIL=MELEME 68 : CALL ECROBJ('MAILLAGE',MELEME) 68 : CALL CLINB 69 : IF (IERR.NE.0) RETURN 69 : CALL LIROBJ('MAILLAGE',MLINB,1,IRET) 70 : C write(6,*)' AVT TQ2CF' 71 : NOMC=' ' 71 : CALL TQ2CF(MAIL,MELEMQ,MELEMC, 72 : & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR) 73 : MELEME=MLINB 74 : IQUAD=0 75 : 76 : ELSEIF(IKR.NE.2.AND.MACRO.EQ.0.AND.INEFMD.NE.1)THEN 77 : C au depart des QUADs ou QUAF -> QUAF 78 : C write(6,*)'au depart des QUADs ou QUAF -> QUAF' 79 : 79 : CALL ECROBJ('MAILLAGE',MELEME) 79 : CALL C20227 80 : IF (IERR.NE.0) RETURN 80 : CALL LIROBJ('MAILLAGE',MELEME,1,IRET) 81 : MAIL=MELEME 82 : NOMC=' ' 82 : CALL TQ2CF(MAIL,MELEMQ,MELEMC, 83 : & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR) 84 : IQUAD=1 85 : 86 : ELSEIF(IKR.EQ.2.AND.MACRO.EQ.0)THEN 87 : C au depart des LINEs -> LINE 88 : C write(6,*)'au depart des LINEs -> LINE' 89 : 89 : CALL ECROBJ('MAILLAGE',MELEME) 89 : CALL CHANQU 89 : CALL C20227 90 : IF (IERR.NE.0) RETURN 90 : CALL LIROBJ('MAILLAGE',MELEME,1,IRET) 91 : MAIL=MELEME 91 : CALL CQF2LN(MELEME,MLINE) 92 : C write(6,*)' AVT TQ2CF' 93 : NOMC=' ' 93 : CALL TQ2CF(MAIL,MELEMQ,MELEMC, 94 : & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR) 95 : MELEME=MLINE 96 : IQUAD=0 97 : 98 : ELSEIF((IKR.EQ.3.OR.IKR.EQ.4).AND.MACRO.NE.0)THEN 99 : C au depart des QUADs -> MACRO 100 : C write(6,*)'au depart des QUADs -> MACRO ' 101 : 102 : MACRO=MELEME 102 : CALL ECROBJ('MAILLAGE',MELEME) 102 : CALL CMACRO 103 : IF (IERR.NE.0) RETURN 103 : CALL LIROBJ('MAILLAGE',MACRO1,1,IRET) 103 : CALL ECROBJ('MAILLAGE',MACRO1) 103 : CALL CQ2L 104 : IF (IERR.NE.0) RETURN 104 : CALL LIROBJ('MAILLAGE',MELEME,1,IRET) 105 : MAIL=MELEME 106 : NOMC=' ' 106 : CALL TQ2CF(MAIL,MELEMQ,MELEMC, 107 : & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR) 108 : IQUAD=0 109 : 110 : ELSEIF(IKR.EQ.1.AND.MACRO.NE.0)THEN 111 : C au depart des QUAFs -> MACRO 112 : C write(6,*)'au depart des QUAFs -> MACRO ' 113 : 114 : MAIL=MELEME 115 : MACRO=MELEME 115 : CALL CQF2MC(MELEME,MACRO1) 116 : IF (IERR.NE.0) RETURN 116 : CALL ECROBJ('MAILLAGE',MACRO1) 116 : CALL CQ2L 117 : IF (IERR.NE.0) RETURN 117 : CALL LIROBJ('MAILLAGE',MELEME,1,IRET) 118 : NOMC=' ' 118 : CALL TQ2CF(MAIL,MELEMQ,MELEP0, 119 : & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR) 120 : 120 : CALL TQ2CF(MELEME,MQ,MELEMC, 121 : & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR) 122 : 122 : C? CALL KRECTR(MELEME,MELEMC) 123 : IQUAD=0 124 : 125 : ELSEIF(IKR.EQ.1.AND.INEFMD.EQ.1)THEN 126 : C au depart des QUAFs -> LINE 127 : C write(6,*)'au depart des QUAFs -> LINE ' 128 : 129 : MAIL=MELEME 130 : C write(6,*)' KKDOM QUAFs -> LINE' 131 : NOMC=' ' 131 : CALL TQ2CF(MAIL,MELEMQ,MELEMC, 132 : & MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR) 132 : CALL CQF2LN(MELEME,MLINE) 133 : MELEME=MLINE 134 : C? MELEME=MAIL 135 : IQUAD=0 136 : 137 : ENDIF 138 : 139 : C write(6,*)' APR MTABI=',mtabi 139 : CALL CRTABL(MTABD) 139 : CALL ECMM(MTABD,'SOUSTYPE','DOMAINE') 139 : CALL ECME(MTABD,'PRECONDI',0) 140 : C write(6,*)' QUAF MELEMQ=',MELEMQ 140 : C? call ecrobj('MAILLAGE',MELEMQ) 140 : C? call prlist 140 : CALL ECMO(MTABD,'QUAF','MAILLAGE',MELEMQ) 140 : IF(MTABI.NE.0) CALL ECMO(MTABD,'PERE','TABLE',MTABI) 140 : CALL ECMM(MTABD,'NOMDOM',NOMDOM) 140 : CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEME) 140 : CALL ECME(MTABD,'INEFMD',INEFMD) 141 : IF(MACRO.NE.0)THEN 141 : CALL ECMO(MTABD,'MACRO','MAILLAGE',MACRO) 141 : CALL ECMO(MTABD,'QUAF ','MAILLAGE',MACRO) 141 : CALL ECMO(MTABD,'MACRO1','MAILLAGE',MACRO1) 142 : ELSEIF(IQUAD.EQ.1)THEN 142 : CALL ECMO(MTABD,'QUADRATIQUE','MAILLAGE',MELEME) 142 : CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEMQ) 143 : MQ=MELEMQ 144 : MELEMQ=MELEME 145 : MELEME=MQ 146 : ENDIF 147 : 148 : C write(6,*)' MELEF1,MELEMF,MELEMP,MELEMC,MELAF=', 149 : C &MELEF1,MELEMF,MELEMP,MELEMC,MELAF 149 : CALL ECMO(MTABD,'FACE','MAILLAGE',MELEF1) 149 : CALL ECMO(MTABD,'FACEL','MAILLAGE',MELEMF) 149 : CALL ECMO(MTABD,'FACEP','MAILLAGE',MELEMP) 149 : CALL ECMO(MTABD,'CENTRE','MAILLAGE',MELEMC) 149 : CALL ECMO(MTABD,'ELTFA','MAILLAGE',MELAF) 149 : CALL ECMO(MTABD,'FACEL2','MAILLAGE',MELEF2) 149 : CALL ECMO(MTABD,'MAILFACE','MAILLAGE',MFF2) 149 : CALL ECMF(MTABD,'TOLER',TOLER) 150 : 151 : IF(MACRO.NE.0)THEN 152 : IF(MELEP0.NE.0) 152 : &CALL ECMO(MTABD,'CENTREP0','MAILLAGE',MELEP0) 152 : C CALL KRECTR(MELEME,MELEMC) 152 : CALL ECMO(MTABD,'CENTRE','MAILLAGE',MELEMC) 153 : COEF=0.D0 154 : C write(6,*)' APPEL a KMLSTB MACRO1=',MACRO1 154 : CALL KMLSTB(MACRO1,MELEME,MELEMC,MELSTB,MCHPOC, 155 : & IRETM,SGA,SEPS,SEPSD,COEF) 156 : C write(6,*)' RETOUR de KMLSTB ' 157 : IF(IRETM.EQ.1)THEN 157 : CALL ECMO(MTABD,'MELSTB','MAILLAGE',MELSTB) 157 : CALL ECMO(MTABD,'MCHPOC','CHPOINT ',MCHPOC) 158 : ENDIF 159 : ENDIF 160 : 160 : C? CALL ECRCHA('POI1') 160 : C? CALL ECROBJ('MAILLAGE',MELEME) 160 : C? CALL ECROBJ('MAILLAGE',MAIL ) 160 : C? CALL PRCHAN 160 : C? CALL LIROBJ('MAILLAGE',MELEMS,1,IRET) 161 : C? IF(IRET.EQ.0)RETURN 161 : CALL CM2PO1(MELEME,MELEMS) 161 : CALL ECMO(MTABD,'SOMMET','MAILLAGE',MELEMS) 162 : C???? IF(MELEMS.EQ.0)RETURN 163 : 164 : C write(6,*)' MTABI=',mtabi,' retour si 0 ' 165 : IF(MTABI.NE.0)THEN 166 : 167 : C In CRTABL -> SEGINI MTBT0 167 : CALL CRTABL(MTBT0) 167 : CALL ECME(MTBT0,'PRECONDI',0) 167 : CALL NOMOBJ('TABLE','tabl0tmp',MTBT0) 168 : 168 : CALL ECMO(MTBT0,'QUAF','MAILLAGE',MELEMQ) 168 : CALL ECMO(MTBT0,'SOMMET','MAILLAGE',MELEMS) 168 : CALL ECMO(MTBT0,'FACE ','MAILLAGE',MELEF1) 168 : CALL ECMO(MTBT0,'FACEL','MAILLAGE',MELEMF) 168 : CALL ECMO(MTBT0,'FACEP','MAILLAGE',MELEMP) 168 : CALL ECMO(MTBT0,'CENTRE','MAILLAGE',MELEMC) 168 : CALL ECMO(MTBT0,'ELTFA','MAILLAGE',MELAF) 168 : CALL ECMO(MTBT0,'FACEL2','MAILLAGE',MELEF2) 168 : CALL ECMO(MTBT0,'MAILFACE','MAILLAGE',MFF2) 168 : CALL ECMO(MTBT0,'MAILLAGE','MAILLAGE',MELEME) 169 : 170 : IF(MACRO.NE.0)THEN 170 : CALL ECMO(MTBT0,'MACRO','MAILLAGE',MACRO) 170 : CALL ECMO(MTBT0,'MACRO1','MAILLAGE',MACRO1) 171 : IF(IRETM.EQ.1)THEN 171 : CALL ECMO(MTBT0,'MELSTB','MAILLAGE',MELSTB) 171 : CALL ECMO(MTBT0,'MCHPOC','CHPOINT ',MCHPOC) 172 : ENDIF 173 : ELSEIF(IQUAD.EQ.1)THEN 173 : CALL ECMO(MTBT0,'MELEMQ','MAILLAGE',MELEMQ) 174 : ENDIF 175 : 176 : C write(6,*)' On vérifie l inclusion des points sommets ' 177 : C On vérifie l'inclusion des points sommets (on peut avoir créé des pts centre) 178 : TYPI='MAILLAGE' 178 : CALL ACMO(MTABI,'SOMMET',TYPI,MSI) 178 : CALL ACMO(MTABI,'FACE',TYPI,MFI) 178 : CALL ACMO(MTABI,'CENTRE',TYPI,MCI) 178 : CALL ECROBJ('MAILLAGE',MFI) 178 : CALL ECROBJ('MAILLAGE',MCI) 178 : CALL PRFUSE 178 : CALL ECROBJ('MAILLAGE',MSI) 178 : CALL PRFUSE 178 : CALL ECROBJ('MAILLAGE',MELEMS) 178 : CALL PRFUSE 178 : CALL ECROBJ('MAILLAGE',MELEF1) 178 : CALL PRFUSE 178 : CALL ECROBJ('MAILLAGE',MELEMC) 178 : CALL PRFUSE 178 : CALL ECRREE(TOLER) 178 : CALL PRELIM(0) 178 : CALL LIROBJ('MAILLAGE',MMMMM,1,IRET) 179 : ENDIF 180 : C write(6,*)' APRES verification ' 181 : 182 : SEGACT MELEF1 183 : NBFD=MELEF1.NUM(/2) 184 : SEGDES MELEF1 185 : SEGACT MELEMC 186 : NELD=MELEMC.NUM(/2) 187 : SEGDES MELEMC 188 : SEGACT MELEMS 189 : NPTD=MELEMS.NUM(/2) 190 : SEGDES MELEMS 191 : 191 : CALL ECME(MTABD,'NPTD',NPTD) 191 : CALL ECME(MTABD,'NELD',NELD) 191 : CALL ECME(MTABD,'NBFD',NBFD) 192 : 193 : C write(6,*)' FIN KKDOM ********************** ' 194 : 195 : RETURN 196 : END 197 : 198 : 199 : 200 : 201 : 202 : 203 : 204 : 205 :
© Cast3M 2003 - All rights reserved.
Disclaimer