C KDAM SOURCE CHAT 07/10/29 21:21:35 5940 SUBROUTINE KDAM C************************************************************************ C C OBJET : Cree une table de soustype DOMAINE C SYNTAXE : A = KDOM OBJ1 C C OBJ1 objet 'MAILLAGE' C IMPR impressions de controle C La table cree contient les informations suivantes: C C Indice Objet C Type Valeur Type Valeur C MOT SOUSTYPE MOT DOMAINE C MOT MAILLAGE MAILLAGE C MOT SOMMET MAILLAGE C MOT CENTRE MAILLAGE C MOT FACE MAILLAGE C MOT FACEL MAILLAGE C MOT NPTD ENTIER C MOT NELD ENTIER C MOT NBFD ENTIER C MOT OBJINCLU LISTMOTS C************************************************************************ IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (NMO1=4) CHARACTER*8 MO1(NMO1) CHARACTER*8 NOM,TYPEL(20),NEM,TYPE,NOMI,MTYP,TYPI PARAMETER (LM1=9) CHARACTER*8 LIST1(LM1),LIST2(LM1) PARAMETER (NMEL=8) CHARACTER*4 MOEL(NMEL) DIMENSION SGA(NMEL),SEPS(NMEL),SEPSD(NMEL) C*** -INC CCOPTIO -INC CCGEOME -INC SMLMOTS POINTEUR TABOG.MLMOTS -INC SMELEME POINTEUR MELEMS.MELEME,MELEMC.MELEME,MELEF1.MELEME POINTEUR MELEMP.MELEME -INC SMCOORD -INC SMLENTI -INC SMTABLE POINTEUR MTABD.MTABLE POINTEUR MTABI.MTABLE,MTBT0.MTABLE DATA MO1/'IMPR ','INCL ','MACRO ',' '/ DATA LIST1/'VOLUME ','COTE ','DIAMAX ','DIAMIN ', & 'NORMALE ','SURFACE ','ORIENTAT','DSOMMET ','DCENTRE '/ DATA LIST2/'XXVOLUM ','XXCOTE ','XXDIAME ','XXDIEMIN', & 'XXNORMAF','XXSURFAC','XXNORMAE','XXDIAGSI','XXVOLUM '/ DATA SGA/1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0/ DATA SEPS/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0/ DATA SEPSD/8*0.D0/ DATA MOEL/'TRI6','QUA8','SEG3','CU20','PR15','TE10','PY13','CHAH'/ C*** COEF=0.D0 KCHAHU=0 MTABI=0 MACRO=0 CALL LIROBJ('MAILLAGE',MELEME,0,IRET) IF(IRET.EQ.0)THEN CALL LIROBJ('TABLE',MTABLE,1,IRET) IF(IRET.EQ.0)THEN WRITE(6,*)' On attend un objet MAILLAGE ou un objet TABLE' RETURN ENDIF CALL LIRCHA(NOM,1,LCHAR) IF(LCHAR.EQ.0)THEN WRITE(6,*)' On attend une CHAINE' RETURN ENDIF CALL OPTLI(IP,LIST1,NOM,LM1) IF(IP.NE.0)THEN NOMI=LIST2(IP) ELSE NOMI=NOM ENDIF CALL LEKTAB(MTABLE,NOMI,IPOINT) IF(IPOINT.EQ.0)RETURN TYPE=' ' C -> In ACCTAB : SEGACT MTABLE CALL ACMO(MTABLE,NOMI,TYPE,IPOINT) SEGDES MTABLE CALL ECROBJ(TYPE,IPOINT) RETURN ENDIF CALL XDIAMM(MELEME,DIAM) DIAM=DIAM*0.0003D0 CALL LIRREE(TOLER,0,IRET) IF(IRET.EQ.0)TOLER=DIAM CALL QUENOM(NOM) IMPR=0 1 CONTINUE 21 CONTINUE CALL QUETYP(MTYP,0,IRET) IP=0 IF(MTYP.EQ.'MOT')THEN CALL LIRCHA(NOM,1,LCHAR) IF(NOM.EQ.' ')GO TO 21 CALL OPTLI(IP,MO1,NOM,NMO1) IF(IP.EQ.4)IP=0 ENDIF IF(IP.EQ.1)THEN IMPR=1 GO TO 1 ELSEIF(IP.EQ.2)THEN CALL LIROBJ('TABLE',MTABI,1,IRET) IF(IRET.EQ.0)RETURN CALL LIRREE(TOLER,0,IRET) IF(IRET.EQ.0)TOLER=DIAM GO TO 1 ELSEIF(IP.EQ.3)THEN MACRO=1 11 CONTINUE CALL LIRMOT(MOEL,NMEL,IPE,0) IF(IPE.EQ.0)GO TO 1 IF(IPE.EQ.8)THEN CALL LIRREE(XVALC,0,IRET) IF(IRET.EQ.1)THEN KCHAHU=1 COEF=XVALC ENDIF GO TO 11 ENDIF CALL LIRREE(XVAL1,1,IRET) IF(IRET.EQ.0)RETURN CALL LIRREE(XVAL2,1,IRET) IF(IRET.EQ.0)RETURN CALL LIRREE(XVAL3,1,IRET) IF(IRET.EQ.0)RETURN SGA(IPE)=XVAL1 SEPS(IPE)=XVAL2 SEPSD(IPE)=XVAL3 GO TO 11 ELSE GO TO 2 ENDIF 2 CONTINUE C On verifie que si la directive INCL est présente les SPG C des points sommets sont bien inclus IF(MTABI.NE.0)THEN TYPI='MAILLAGE' CALL ACMO(MTABI,'SOMMET',TYPI,MSI) CALL KRIPAD(MSI,MLENTI) CALL VERPAD(MLENTI,MELEME,IRET) IF(IRET.NE.0)THEN WRITE(6,*)' Opérateur DOMA ' WRITE(6,*)' Le maillage n''est pas contenu dans celui de' & ,' la table donnée pour la directive INCL ' RETURN ENDIF SEGSUP MLENTI ENDIF IF(MACRO.NE.0)THEN MACRO=MELEME C In CRTABL -> SEGINI MTBT0 CALL CRTABL(MTBT0) CALL NOMOBJ('TABLE','tabl0tmp',MTBT0) IF(IDIM.EQ.2)THEN C write(6,*)' KCHAHU,coef=',KCHAHU,coef IF(KCHAHU.EQ.1)CALL CHAHUT(MACRO,COEF) CALL KTRSF(MACRO,MELEME,MTBT0,IRET,SGA,SEPS,SEPSD,COEF) ELSE CALL KTRS3(MACRO,MELEME,MTBT0,IRET,SGA,SEPS,SEPSD,COEF) CALL ECROBJ('MAILLAGE',MELEME) CALL ECRREE(TOLER) CALL PRELIM(0) CALL LIROBJ('MAILLAGE',MMMMM,1,IRET) ENDIF IF(IRET.EQ.0)RETURN IF(MTABI.NE.0)THEN TYPI='MAILLAGE' CALL ACMO(MTABI,'SOMMET',TYPI,MSI) CALL ECROBJ('MAILLAGE',MSI) CALL ECROBJ('MAILLAGE',MELEME) CALL PRFUSE CALL ECRREE(TOLER) CALL PRELIM(0) CALL LIROBJ('MAILLAGE',MMMMM,1,IRET) ENDIF ENDIF C Fin MACRO C Debut KFCE IF(MTABI.NE.0)THEN CALL ECRREE(TOLER) CALL ECROBJ('TABLE',MTABI) CALL ECRCHA('INCL') ENDIF CALL ECROBJ('MAILLAGE',MELEME) CALL ECRREE(TOLER) MELEMQ=0 CALL KFCE(IQUAD,MELEMQ) CALL LIROBJ('MAILLAGE',MELAF,1,IRET) CALL LIROBJ('MAILLAGE',MELEMC,1,IRET) CALL LIROBJ('MAILLAGE',MELEMP,1,IRET) CALL LIROBJ('MAILLAGE',MELEMF,1,IRET) CALL LIROBJ('MAILLAGE',MELEF1,1,IRET) IF(IRET.EQ.0)RETURN CALL CRTABL(MTABD) CALL ECMM(MTABD,'SOUSTYPE','DOMAINE') IF(MTABI.NE.0) CALL ECMO(MTABD,'PERE','TABLE',MTABI) CALL ECMM(MTABD,'NOMDOM',NOM) CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEME) IF(MACRO.NE.0)THEN CALL ECMO(MTABD,'MACRO','MAILLAGE',MACRO) ELSEIF(IQUAD.EQ.1)THEN CALL ECMO(MTABD,'QUADRATIQUE','MAILLAGE',MELEME) CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEMQ) MQ=MELEMQ MELEMQ=MELEME MELEME=MQ ENDIF CALL ECMO(MTABD,'FACE','MAILLAGE',MELEF1) CALL ECMO(MTABD,'FACEL','MAILLAGE',MELEMF) CALL ECMO(MTABD,'FACEP','MAILLAGE',MELEMP) CALL ECMO(MTABD,'CENTRE','MAILLAGE',MELEMC) CALL ECMO(MTABD,'ELTFA','MAILLAGE',MELAF) CALL ECMF(MTABD,'TOLER',TOLER) CG TYPE=' ' CG write(6,*)' avt MTBT0 MFICEL ',MTBT0 CG CALL ACMO(MTBT0,'MFICEL',TYPE,MFICEL) CG IF(TYPE.NE.'MAILLAGE')MFICEL=0 CG IF(MACRO.NE.0.AND.MFICEL.NE.0)THEN IF(MACRO.NE.0)THEN C write(6,*)' OK ds MACRO ',toler TYPI='MAILLAGE' CALL ACMO(MTBT0,'MCTREI',TYPI,MCTREI) CALL ECMO(MTABD,'MCTREI','MAILLAGE',MCTREI) CALL ECROBJ('MAILLAGE',MELEMC) CALL ECROBJ('MAILLAGE',MCTREI) CALL PRFUSE CALL ECRREE(TOLER) CALL PRELIM(0) C? CALL PRTRAC C write(6,*)' premier PRELIM ' CALL ECROBJ('MAILLAGE',MELEF1) CALL PRFUSE CALL ECRREE(TOLER) CALL PRELIM(0) C write(6,*)' second PRELIM ' CALL LIROBJ('MAILLAGE',MMMMM,1,IRET) TYPE=' ' CALL ACMO(MTBT0,'MCHPOC',TYPE,MCHPOC) IF(TYPE.EQ.'CHPOINT ')THEN CALL ECMO(MTABD,'MCHPOC','CHPOINT ',MCHPOC) TYPI='MAILLAGE' CALL ACMO(MTBT0,'MELSTB',TYPI,MELSTB) CALL ECMO(MTABD,'MELSTB','MAILLAGE',MELSTB) CG si utilise, remplacer MAILLAGE par TYPI TYPI='MAILLAGE' C CALL ACMO(MTBT0,'MFACEI',TYPI,MFACEI) C CALL ACMO(MTBT0,'MELTFI',TYPI,MELTFI) C CALL ACMO(MTBT0,'MELELI',TYPI,MELELI) C CALL ACMO(MTBT0,'MCTREI',TYPI,MCTREI) C CALL ACMO(MTBT0,'MCHPOF','CHPOINT ',MCHPOF) C CALL ECMO(MTABD,'FACEI','MAILLAGE',MFACEI) C CALL ECMO(MTABD,'ELTFAI','MAILLAGE',MELTFI) C CALL ECMO(MTABD,'FACELI','MAILLAGE',MFICEL) C CALL ECMO(MTABD,'MELELI','MAILLAGE',MELELI) C CALL ECMO(MTABD,'MCHPOF','CHPOINT ',MCHPOF) ENDIF ENDIF CALL ECRCHA('POI1') CALL ECROBJ('MAILLAGE',MELEME) CALL PRCHAN CALL LIROBJ('MAILLAGE',MELEMS,1,IRET) IF(IRET.EQ.0)RETURN CALL ECMO(MTABD,'SOMMET','MAILLAGE',MELEMS) IF(MELEMS.EQ.0)RETURN SEGACT MELEF1 NBFD=MELEF1.NUM(/2) SEGDES MELEF1 SEGACT MELEMC NELD=MELEMC.NUM(/2) SEGDES MELEMC SEGACT MELEMS NPTD=MELEMS.NUM(/2) SEGDES MELEMS CALL ECME(MTABD,'NPTD',NPTD) CALL ECME(MTABD,'NELD',NELD) CALL ECME(MTABD,'NBFD',NBFD) CALL ECROBJ('MAILLAGE',MELEME) CALL REFE CALL LIROBJ('LISTMOTS',TABOG,0,IRET) CALL ECMO(MTABD,'OBJINCLU','LISTMOTS',TABOG) NBTYP=0 SEGACT MELEME NBSOUS=LISOUS(/1) IF(NBSOUS.EQ.0)NBSOUS=1 DO 3 L=1,NBSOUS IF(NBSOUS.NE.1)THEN IPT1=LISOUS(L) SEGACT IPT1 ELSE IPT1=MELEME ENDIF NBTYP=NBTYP+1 NEM=NOMS(IPT1.ITYPEL)//' ' C CALL KALPBG(NEM,'FONFORM0',IZFFM) C CALL ECMO(MTABD,'FONFORM0','FONFORM0',IZFFM) C CALL KALPBG(NEM,'FONFORM ',IZFFM) C CALL ECMO(MTABD,'FONFORM','FONFORM',IZFFM) TYPEL(NBTYP)=NEM IF(NBSOUS.NE.1)SEGDES IPT1 3 CONTINUE SEGDES MELEME IF(IMPR.NE.0)THEN WRITE(6,1909)NOM,IDIM,NPTD,NELD 1909 FORMAT(/1X,9(8H********)/5X,'DOMAINE ',A8,' CREE DIM ESPACE:', & I2,' NB DE NOEUDS :',I6,/42X, & ' NB D ELEMENTS :',I6,/) WRITE(6,1919) DO M=1,NBTYP WRITE(6,1920) TYPEL(M) ENDDO 1919 FORMAT(5X,'TYPE DES ELEMENTS CONSTITUANT LE DOMAINE',/) 1920 FORMAT(5X,A8/) IF(TABOG.NE.0) THEN WRITE(6,1983) 1983 FORMAT(10X,' LISTE DES OBJETS INCLUS DANS LE DOMAINE ',/) SEGACT TABOG NBO=TABOG.MOTS(/2) WRITE(6,1982)(TABOG.MOTS(MM),MM=1,NBO) 1982 FORMAT(7(2X,A8)) SEGDES TABOG WRITE(6,1928) 1928 FORMAT(//1X,9('********')/) ENDIF ENDIF SEGDES MTABD CALL ECROBJ('TABLE ',MTABD) RETURN END