1 : C KDAM SOURCE CHAT 07/10/29 21:21:35 5940 2 : SUBROUTINE KDAM 3 : C************************************************************************ 4 : C 5 : C OBJET : Cree une table de soustype DOMAINE 6 : C SYNTAXE : A = KDOM OBJ17 : C 8 : C OBJ1 objet 'MAILLAGE' 9 : C IMPR impressions de controle 10 : C La table cree contient les informations suivantes: 11 : C 12 : C Indice Objet 13 : C Type Valeur Type Valeur 14 : C MOT SOUSTYPE MOT DOMAINE 15 : C MOT MAILLAGE MAILLAGE 16 : C MOT SOMMET MAILLAGE 17 : C MOT CENTRE MAILLAGE 18 : C MOT FACE MAILLAGE 19 : C MOT FACEL MAILLAGE 20 : C MOT NPTD ENTIER 21 : C MOT NELD ENTIER 22 : C MOT NBFD ENTIER 23 : C MOT OBJINCLU LISTMOTS 24 : C************************************************************************ 25 : IMPLICIT INTEGER(I-N) 26 : IMPLICIT REAL*8 (A-H,O-Z) 27 : PARAMETER (NMO1=4) 28 : CHARACTER*8 MO1(NMO1) 29 : CHARACTER*8 NOM,TYPEL(20),NEM,TYPE,NOMI,MTYP,TYPI 30 : PARAMETER (LM1=9) 31 : CHARACTER*8 LIST1(LM1),LIST2(LM1) 32 : PARAMETER (NMEL=8) 33 : CHARACTER*4 MOEL(NMEL) 34 : DIMENSION SGA(NMEL),SEPS(NMEL),SEPSD(NMEL) 35 : C*** 36 : -INC CCOPTIO 37 : -INC CCGEOME 38 : -INC SMLMOTS 39 : POINTEUR TABOG.MLMOTS 40 : -INC SMELEME 41 : POINTEUR MELEMS.MELEME,MELEMC.MELEME,MELEF1.MELEME 42 : POINTEUR MELEMP.MELEME 43 : -INC SMCOORD 44 : -INC SMLENTI 45 : -INC SMTABLE 46 : POINTEUR MTABD.MTABLE 47 : POINTEUR MTABI.MTABLE,MTBT0.MTABLE 48 : DATA MO1/'IMPR ','INCL ','MACRO ',' '/ 49 : DATA LIST1/'VOLUME ','COTE ','DIAMAX ','DIAMIN ', 50 : & 'NORMALE ','SURFACE ','ORIENTAT','DSOMMET ','DCENTRE '/ 51 : DATA LIST2/'XXVOLUM ','XXCOTE ','XXDIAME ','XXDIEMIN', 52 : & 'XXNORMAF','XXSURFAC','XXNORMAE','XXDIAGSI','XXVOLUM '/ 53 : DATA SGA/1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0/ 54 : DATA SEPS/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0/ 55 : DATA SEPSD/8*0.D0/ 56 : DATA MOEL/'TRI6','QUA8','SEG3','CU20','PR15','TE10','PY13','CHAH'/ 57 : C*** 58 : 59 : COEF=0.D0 60 : KCHAHU=0 61 : MTABI=0 62 : MACRO=0 62 : CALL LIROBJ('MAILLAGE',MELEME,0,IRET) 63 : IF(IRET.EQ.0)THEN 63 : CALL LIROBJ('TABLE',MTABLE,1,IRET) 64 : IF(IRET.EQ.0)THEN 65 : WRITE(6,*)' On attend un objet MAILLAGE ou un objet TABLE' 66 : RETURN 67 : ENDIF 67 : CALL LIRCHA(NOM,1,LCHAR) 68 : IF(LCHAR.EQ.0)THEN 69 : WRITE(6,*)' On attend une CHAINE' 70 : RETURN 71 : ENDIF 71 : CALL OPTLI(IP,LIST1,NOM,LM1) 72 : IF(IP.NE.0)THEN 73 : NOMI=LIST2(IP) 74 : ELSE 75 : NOMI=NOM 76 : ENDIF 76 : CALL LEKTAB(MTABLE,NOMI,IPOINT) 77 : IF(IPOINT.EQ.0)RETURN 78 : TYPE=' ' 79 : C -> In ACCTAB : SEGACT MTABLE 79 : CALL ACMO(MTABLE,NOMI,TYPE,IPOINT) 80 : SEGDES MTABLE 80 : CALL ECROBJ(TYPE,IPOINT) 81 : RETURN 82 : ENDIF 83 : 84 : 84 : CALL XDIAMM(MELEME,DIAM) 85 : DIAM=DIAM*0.0003D0 85 : CALL LIRREE(TOLER,0,IRET) 86 : IF(IRET.EQ.0)TOLER=DIAM 87 : 87 : CALL QUENOM(NOM) 88 : 89 : IMPR=0 90 : 1 CONTINUE 91 : 92 : 21 CONTINUE 92 : CALL QUETYP(MTYP,0,IRET) 93 : IP=0 94 : IF(MTYP.EQ.'MOT')THEN 94 : CALL LIRCHA(NOM,1,LCHAR) 95 : IF(NOM.EQ.' ')GO TO 21 95 : CALL OPTLI(IP,MO1,NOM,NMO1) 96 : IF(IP.EQ.4)IP=0 97 : ENDIF 98 : 99 : IF(IP.EQ.1)THEN 100 : 101 : IMPR=1 102 : GO TO 1 103 : 104 : ELSEIF(IP.EQ.2)THEN 105 : 105 : CALL LIROBJ('TABLE',MTABI,1,IRET) 106 : IF(IRET.EQ.0)RETURN 106 : CALL LIRREE(TOLER,0,IRET) 107 : IF(IRET.EQ.0)TOLER=DIAM 108 : GO TO 1 109 : 110 : ELSEIF(IP.EQ.3)THEN 111 : 112 : MACRO=1 113 : 11 CONTINUE 113 : CALL LIRMOT(MOEL,NMEL,IPE,0) 114 : IF(IPE.EQ.0)GO TO 1 115 : IF(IPE.EQ.8)THEN 116 : 116 : CALL LIRREE(XVALC,0,IRET) 117 : IF(IRET.EQ.1)THEN 118 : KCHAHU=1 119 : COEF=XVALC 120 : ENDIF 121 : GO TO 11 122 : 123 : ENDIF 124 : 124 : CALL LIRREE(XVAL1,1,IRET) 125 : IF(IRET.EQ.0)RETURN 125 : CALL LIRREE(XVAL2,1,IRET) 126 : IF(IRET.EQ.0)RETURN 126 : CALL LIRREE(XVAL3,1,IRET) 127 : IF(IRET.EQ.0)RETURN 128 : SGA(IPE)=XVAL1 129 : SEPS(IPE)=XVAL2 130 : SEPSD(IPE)=XVAL3 131 : GO TO 11 132 : 133 : ELSE 134 : GO TO 2 135 : ENDIF 136 : 137 : 2 CONTINUE 138 : 139 : C On verifie que si la directive INCL est présente les SPG 140 : C des points sommets sont bien inclus 141 : 142 : IF(MTABI.NE.0)THEN 143 : TYPI='MAILLAGE' 143 : CALL ACMO(MTABI,'SOMMET',TYPI,MSI) 143 : CALL KRIPAD(MSI,MLENTI) 143 : CALL VERPAD(MLENTI,MELEME,IRET) 144 : IF(IRET.NE.0)THEN 145 : WRITE(6,*)' Opérateur DOMA ' 146 : WRITE(6,*)' Le maillage n''est pas contenu dans celui de' 147 : & ,' la table donnée pour la directive INCL ' 148 : RETURN 149 : ENDIF 150 : SEGSUP MLENTI 151 : ENDIF 152 : 153 : IF(MACRO.NE.0)THEN 154 : 155 : MACRO=MELEME 156 : C In CRTABL -> SEGINI MTBT0 156 : CALL CRTABL(MTBT0) 156 : CALL NOMOBJ('TABLE','tabl0tmp',MTBT0) 157 : IF(IDIM.EQ.2)THEN 158 : 159 : C write(6,*)' KCHAHU,coef=',KCHAHU,coef 159 : IF(KCHAHU.EQ.1)CALL CHAHUT(MACRO,COEF) 159 : CALL KTRSF(MACRO,MELEME,MTBT0,IRET,SGA,SEPS,SEPSD,COEF) 160 : 161 : ELSE 161 : CALL KTRS3(MACRO,MELEME,MTBT0,IRET,SGA,SEPS,SEPSD,COEF) 161 : CALL ECROBJ('MAILLAGE',MELEME) 161 : CALL ECRREE(TOLER) 161 : CALL PRELIM(0) 161 : CALL LIROBJ('MAILLAGE',MMMMM,1,IRET) 162 : ENDIF 163 : IF(IRET.EQ.0)RETURN 164 : 165 : IF(MTABI.NE.0)THEN 166 : TYPI='MAILLAGE' 166 : CALL ACMO(MTABI,'SOMMET',TYPI,MSI) 166 : CALL ECROBJ('MAILLAGE',MSI) 166 : CALL ECROBJ('MAILLAGE',MELEME) 166 : CALL PRFUSE 166 : CALL ECRREE(TOLER) 166 : CALL PRELIM(0) 166 : CALL LIROBJ('MAILLAGE',MMMMM,1,IRET) 167 : ENDIF 168 : 169 : ENDIF 170 : 171 : C Fin MACRO 172 : 173 : C Debut KFCE 174 : 175 : IF(MTABI.NE.0)THEN 175 : CALL ECRREE(TOLER) 175 : CALL ECROBJ('TABLE',MTABI) 175 : CALL ECRCHA('INCL') 176 : ENDIF 176 : CALL ECROBJ('MAILLAGE',MELEME) 176 : CALL ECRREE(TOLER) 177 : 178 : MELEMQ=0 178 : CALL KFCE(IQUAD,MELEMQ) 178 : CALL LIROBJ('MAILLAGE',MELAF,1,IRET) 178 : CALL LIROBJ('MAILLAGE',MELEMC,1,IRET) 178 : CALL LIROBJ('MAILLAGE',MELEMP,1,IRET) 178 : CALL LIROBJ('MAILLAGE',MELEMF,1,IRET) 178 : CALL LIROBJ('MAILLAGE',MELEF1,1,IRET) 179 : IF(IRET.EQ.0)RETURN 180 : 180 : CALL CRTABL(MTABD) 180 : CALL ECMM(MTABD,'SOUSTYPE','DOMAINE') 180 : IF(MTABI.NE.0) CALL ECMO(MTABD,'PERE','TABLE',MTABI) 180 : CALL ECMM(MTABD,'NOMDOM',NOM) 180 : CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEME) 181 : IF(MACRO.NE.0)THEN 181 : CALL ECMO(MTABD,'MACRO','MAILLAGE',MACRO) 182 : ELSEIF(IQUAD.EQ.1)THEN 182 : CALL ECMO(MTABD,'QUADRATIQUE','MAILLAGE',MELEME) 182 : CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEMQ) 183 : MQ=MELEMQ 184 : MELEMQ=MELEME 185 : MELEME=MQ 186 : ENDIF 187 : 187 : CALL ECMO(MTABD,'FACE','MAILLAGE',MELEF1) 187 : CALL ECMO(MTABD,'FACEL','MAILLAGE',MELEMF) 187 : CALL ECMO(MTABD,'FACEP','MAILLAGE',MELEMP) 187 : CALL ECMO(MTABD,'CENTRE','MAILLAGE',MELEMC) 187 : CALL ECMO(MTABD,'ELTFA','MAILLAGE',MELAF) 187 : CALL ECMF(MTABD,'TOLER',TOLER) 188 : 189 : CG TYPE=' ' 190 : CG write(6,*)' avt MTBT0 MFICEL ',MTBT0 190 : CG CALL ACMO(MTBT0,'MFICEL',TYPE,MFICEL) 191 : CG IF(TYPE.NE.'MAILLAGE')MFICEL=0 192 : CG IF(MACRO.NE.0.AND.MFICEL.NE.0)THEN 193 : 194 : IF(MACRO.NE.0)THEN 195 : C write(6,*)' OK ds MACRO ',toler 196 : TYPI='MAILLAGE' 196 : CALL ACMO(MTBT0,'MCTREI',TYPI,MCTREI) 196 : CALL ECMO(MTABD,'MCTREI','MAILLAGE',MCTREI) 196 : CALL ECROBJ('MAILLAGE',MELEMC) 196 : CALL ECROBJ('MAILLAGE',MCTREI) 196 : CALL PRFUSE 196 : CALL ECRREE(TOLER) 196 : CALL PRELIM(0) 196 : C? CALL PRTRAC 197 : C write(6,*)' premier PRELIM ' 197 : CALL ECROBJ('MAILLAGE',MELEF1) 197 : CALL PRFUSE 197 : CALL ECRREE(TOLER) 197 : CALL PRELIM(0) 198 : C write(6,*)' second PRELIM ' 198 : CALL LIROBJ('MAILLAGE',MMMMM,1,IRET) 199 : TYPE=' ' 199 : CALL ACMO(MTBT0,'MCHPOC',TYPE,MCHPOC) 200 : IF(TYPE.EQ.'CHPOINT ')THEN 200 : CALL ECMO(MTABD,'MCHPOC','CHPOINT ',MCHPOC) 201 : TYPI='MAILLAGE' 201 : CALL ACMO(MTBT0,'MELSTB',TYPI,MELSTB) 201 : CALL ECMO(MTABD,'MELSTB','MAILLAGE',MELSTB) 202 : CG si utilise, remplacer MAILLAGE par TYPI 203 : TYPI='MAILLAGE' 203 : C CALL ACMO(MTBT0,'MFACEI',TYPI,MFACEI) 203 : C CALL ACMO(MTBT0,'MELTFI',TYPI,MELTFI) 203 : C CALL ACMO(MTBT0,'MELELI',TYPI,MELELI) 203 : C CALL ACMO(MTBT0,'MCTREI',TYPI,MCTREI) 203 : C CALL ACMO(MTBT0,'MCHPOF','CHPOINT ',MCHPOF) 203 : C CALL ECMO(MTABD,'FACEI','MAILLAGE',MFACEI) 203 : C CALL ECMO(MTABD,'ELTFAI','MAILLAGE',MELTFI) 203 : C CALL ECMO(MTABD,'FACELI','MAILLAGE',MFICEL) 203 : C CALL ECMO(MTABD,'MELELI','MAILLAGE',MELELI) 203 : C CALL ECMO(MTABD,'MCHPOF','CHPOINT ',MCHPOF) 204 : ENDIF 205 : 206 : ENDIF 207 : 207 : CALL ECRCHA('POI1') 207 : CALL ECROBJ('MAILLAGE',MELEME) 207 : CALL PRCHAN 207 : CALL LIROBJ('MAILLAGE',MELEMS,1,IRET) 208 : IF(IRET.EQ.0)RETURN 208 : CALL ECMO(MTABD,'SOMMET','MAILLAGE',MELEMS) 209 : IF(MELEMS.EQ.0)RETURN 210 : 211 : SEGACT MELEF1 212 : NBFD=MELEF1.NUM(/2) 213 : SEGDES MELEF1 214 : SEGACT MELEMC 215 : NELD=MELEMC.NUM(/2) 216 : SEGDES MELEMC 217 : SEGACT MELEMS 218 : NPTD=MELEMS.NUM(/2) 219 : SEGDES MELEMS 220 : 220 : CALL ECME(MTABD,'NPTD',NPTD) 220 : CALL ECME(MTABD,'NELD',NELD) 220 : CALL ECME(MTABD,'NBFD',NBFD) 221 : 221 : CALL ECROBJ('MAILLAGE',MELEME) 221 : CALL REFE 221 : CALL LIROBJ('LISTMOTS',TABOG,0,IRET) 221 : CALL ECMO(MTABD,'OBJINCLU','LISTMOTS',TABOG) 222 : 223 : NBTYP=0 224 : SEGACT MELEME 225 : NBSOUS=LISOUS(/1) 226 : IF(NBSOUS.EQ.0)NBSOUS=1 227 : DO 3 L=1,NBSOUS 228 : IF(NBSOUS.NE.1)THEN 229 : IPT1=LISOUS(L) 230 : SEGACT IPT1 231 : ELSE 232 : IPT1=MELEME 233 : ENDIF 234 : NBTYP=NBTYP+1 235 : NEM=NOMS(IPT1.ITYPEL)//' ' 235 : C CALL KALPBG(NEM,'FONFORM0',IZFFM) 235 : C CALL ECMO(MTABD,'FONFORM0','FONFORM0',IZFFM) 235 : C CALL KALPBG(NEM,'FONFORM ',IZFFM) 235 : C CALL ECMO(MTABD,'FONFORM','FONFORM',IZFFM) 236 : TYPEL(NBTYP)=NEM 237 : IF(NBSOUS.NE.1)SEGDES IPT1 238 : 3 CONTINUE 239 : SEGDES MELEME 240 : 241 : IF(IMPR.NE.0)THEN 242 : WRITE(6,1909)NOM,IDIM,NPTD,NELD 243 : 1909 FORMAT(/1X,9(8H********)/5X,'DOMAINE ',A8,' CREE DIM ESPACE:', 244 : & I2,' NB DE NOEUDS :',I6,/42X, 245 : & ' NB D ELEMENTS :',I6,/) 246 : WRITE(6,1919) 247 : DO M=1,NBTYP 248 : WRITE(6,1920) TYPEL(M) 249 : ENDDO 250 : 1919 FORMAT(5X,'TYPE DES ELEMENTS CONSTITUANT LE DOMAINE',/) 251 : 1920 FORMAT(5X,A8/) 252 : IF(TABOG.NE.0) THEN 253 : WRITE(6,1983) 254 : 1983 FORMAT(10X,' LISTE DES OBJETS INCLUS DANS LE DOMAINE ',/) 255 : SEGACT TABOG 256 : NBO=TABOG.MOTS(/2) 257 : WRITE(6,1982)(TABOG.MOTS(MM),MM=1,NBO) 258 : 1982 FORMAT(7(2X,A8)) 259 : SEGDES TABOG 260 : WRITE(6,1928) 261 : 1928 FORMAT(//1X,9('********')/) 262 : ENDIF 263 : ENDIF 264 : SEGDES MTABD 264 : CALL ECROBJ('TABLE ',MTABD) 265 : RETURN 266 : END 267 : 268 : 269 : 270 : 271 : 272 : 273 :
© Cast3M 2003 - All rights reserved.
Disclaimer