C KCHT SOURCE GOUNAND 25/11/12 21:15:15 12399 SUBROUTINE KCHT IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C************************************************************************* C Operateur KCHT C C OBJET : Cree un CHAMPOINT TRIO c'est a dire sous-type C SOMMET CENTRE ou FACE C C SYNTAXE : CH1 = KCHT tabdom TYPC TYPG C ; C C tabdom table domaine C C TYPC : SCAL TYPG : SOMMET C VECT CENTRE C FACE C nc nom donne a ou aux composantes C C C C C C************************************************************************* -INC PPARAM -INC CCOPTIO -INC SMCOORD -INC SMCHPOI -INC SMELEME -INC SMLENTI -INC SMLMOTS CHARACTER*8 TYPC,TYPG,LTYPC(3),LTYPG(8),MTYP,TYPE,TYPS CHARACTER*(LOCOMP) NCOS,NCOV(3),NCOSI,NCOVI(3) REAL*8 XVAL(3) DATA LTYPC/'SCAL ','VECT ','MATR '/ DATA LTYPG/'SOMMET ','CENTRE ','FACE ','CENTREP0','CENTREP1', &'MSOMMET ','COMP ','VERIF '/ DATA NCOSI/'SCAL'/ DATA NCOVI/'UX ','UY ','UZ '/ C*** segact mcoord KVERIF=0 MLENTI=0 NCOS=NCOSI NCOV(1)=NCOVI(1) NCOV(2)=NCOVI(2) NCOV(3)=NCOVI(3) XVAL(1) = 0.D0 XVAL(2) = 0.D0 XVAL(3) = 0.D0 MCHPOI = 0 CALL LITDMD(MMODEL,MTABD,IRET) IF(IRET.EQ.0)RETURN IF(MTABD.EQ.0)CALL LEKMOD(MMODEL,MTABD,INEFMD) C INEFMD=1 LINE =2 MACRO =3 QUADRATIQUE =4 LINB C WRITE(*,*)' on cherche les MOT des sous-type du CHPOINT résultat' C C SCAL SOMMET C VECT FACE C CENTRE CALL LIRMOT(LTYPC,3,IPC,1) IF(IPC.EQ.0)RETURN CALL LIRMOT(LTYPG,6,IPG,1) IF(IPG.EQ.0)RETURN IF(IPC.EQ.1)THEN NC=1 ELSEIF(IPC.EQ.2)THEN NC=IDIM ELSEIF(IPC.EQ.3)THEN NC=IDIM*IDIM ENDIF CALL QUETYP(MTYP,0,IRET) IF(IRET.EQ.0)GO TO 90 IF(MTYP.EQ.'MOT')THEN CALL LIRMOT(LTYPG(7),2,IPC,1) IF(IPC.EQ.0)THEN C Il manque le mot-clé %m1:4 MOTERR(1:4)='COMP' CALL ERREUR(396) MOTERR(1:4)='VERI' CALL ERREUR(396) RETURN ENDIF IF(IPC.EQ.1)THEN IF(NC.EQ.1)THEN CALL LIRCHA(NCOS,1,IRET) IF(IRET.EQ.0)RETURN ELSE CALL QUETYP(MTYP,0,IRET) C write(6,*)' MTYP,nc=',MTYP,nc IF(IRET.EQ.0)RETURN IF(MTYP.EQ.'LISTMOTS')THEN CALL LIROBJ('LISTMOTS',MLMOTS,1,IRET) IF(IRET.EQ.0)RETURN SEGACT MLMOTS DO 128 I=1,NC C? CALL LIRCHA(NCOV(I),1,IRET) C? IF(IRET.EQ.0)RETURN NCOV(I)=MOTS(I) 128 CONTINUE ELSEIF(MTYP.EQ.'MOT')THEN DO 129 I=1,NC CALL LIRCHA(NCOV(I),1,IRET) IF(IRET.EQ.0)RETURN 129 CONTINUE ELSE RETURN ENDIF ENDIF ELSEIF(IPC.EQ.2)THEN KVERIF=1 ENDIF CALL QUETYP(MTYP,0,IRET) IF(IRET.EQ.0)GO TO 90 ENDIF IF(IPG.GE.4.AND.IPG.NE.6)THEN IF(INEFMD.NE.2.AND.INEFMD.NE.3.AND.INEFMD.NE.4)THEN C Option %m1:8 incompatible avec les données MOTERR( 1: 8) = LTYPG(IPG) CALL ERREUR(803) RETURN ENDIF ENDIF TYPG=LTYPG(IPG) CALL LEKTAB(MTABD,TYPG,MELEME) NAT=2 NSOUPO=1 SEGACT MELEME N=NUM(/2) SEGINI MCHPOI,MSOUPO,MPOVAL C write(6,*)' KCHT on initialise MCHPOI n,nc=',n,nc MTYPOI=TYPG MOCHDE=TITREE JATTRI(1)=1 IPCHP(1)=MSOUPO IFOPOI=IFOUR IF(NC.EQ.1)THEN C write(6,*)' On attribue le nom de composante :',ncos,' :' NOCOMP(1)=NCOS ELSE DO 127 I=1,NC C write(6,*)' On attribue le nom de composante :',ncov(i),' :' NOCOMP(I)=NCOV(I) 127 CONTINUE ENDIF IGEOC=MELEME IPOVAL=MPOVAL IF(MTYP.EQ.'FLOTTANT'.OR.MTYP.EQ.'ENTIER ')THEN C On initialise le CHPOINT a une constante si c'est un SCAL IF(NC.NE.1)THEN WRITE(6,*)' CHPOINT SCAL Initialisation incompatible ' CALL ERREUR(156) C Le chpoint donné est vide, ou bien son contenu est incompatible avec les n C de composante imposés par le listmots et le mot-clé (donné ou sous-entendu RETURN ENDIF CALL LIRREE(XVAL(1),1,IRET) CALL INITD(VPOCHA,N,XVAL(1)) ELSEIF(MTYP.EQ.'POINT ')THEN IF(NC.EQ.1)THEN WRITE(6,*)' CHPOINT VECT Initialisation incompatible ' CALL ERREUR(156) C Le chpoint donné est vide, ou bien son contenu est incompatible avec les n C de composante imposés par le listmots et le mot-clé (donné ou sous-entendu RETURN ENDIF CALL LIROBJ('POINT ',IP,1,IRET) XVAL(1)=XCOOR((IP-1)*(IDIM+1) +1) XVAL(2)=XCOOR((IP-1)*(IDIM+1) +2) IF(NC.EQ.3)XVAL(3)=XCOOR((IP-1)*(IDIM+1) +3) C On construit le CHPOINT résultat si celui-ci ne l'a pas déjà été ... CALL INITD(VPOCHA,N,XVAL(1)) CALL INITD(VPOCHA(1,2),N,XVAL(2)) IF(NC.EQ.3)CALL INITD(VPOCHA(1,3),N,XVAL(3)) IF(NC.EQ.4.OR.NC.EQ.9)WRITE(6,*)' Cas non encore implemente' ELSEIF(MTYP.NE.'CHPOINT')THEN WRITE(6,*)' Type d objet incorrect pour l initialisation' C Indice %m1:8 : Objet de type %m9:16 incorrect MOTERR(1:8)=' ' MOTERR(9:16)=MTYP CALL ERREUR(787) RETURN ENDIF C write(6,*)' On cherche les champoints à charger ... ' CALL KRIPAD(MELEME,MLENTI) 10 CONTINUE CALL LIROBJ('CHPOINT ',MCHPO1,0,IRET) IF(IRET.EQ.0)GO TO 11 CALL ACTOBJ('CHPOINT ',MCHPO1,1) NSOUP1=MCHPO1.IPCHP(/1) IKCOMP=0 DO 1 L=1,NSOUP1 MSOUP1=MCHPO1.IPCHP(1) NC1=MSOUP1.NOCOMP(/2) DO 2 M=1,NC1 DO 3 K=1,NC C write(6,*)' ncomp1=',MSOUP1.NOCOMP(M),' ncomp=',NOCOMP(K) IF(MSOUP1.NOCOMP(M).EQ.NOCOMP(K))THEN IKCOMP=IKCOMP+1 MELEME=MSOUP1.IGEOC MPOVA1=MSOUP1.IPOVAL NPT=NUM(/2) IKVAL=0 DO 4 I=1,NPT I1=LECT(NUM(1,I)) IF(I1.EQ.0)GO TO 4 IKVAL=IKVAL+1 VPOCHA(I1,K)=MPOVA1.VPOCHA(I,M) 4 CONTINUE IF(IKVAL.EQ.0)THEN write(6,*)' Opérateur KCHT : aucun point pour la composante ', &NOCOMP(M) C Le chpoint donné est vide, ou bien son contenu est incompatible avec les noms Cde composante imposés par le listmots et le mot-clé (donné ou sous-entendu) CALL ERREUR(156) RETURN ENDIF IF(KVERIF.NE.0)THEN write(6,*)' Opérateur KCHT : la composante ',NOCOMP(M), &' a été initialisée' ENDIF ENDIF 3 CONTINUE 2 CONTINUE 1 CONTINUE IF(IKCOMP.EQ.0)THEN write(6,*)' Opérateur KCHT : ' write(6,*)' Aucune composante n''a été initialisée' write(6,*)' Liste des composantes : ' DO 21 L=1,NSOUP1 MSOUP1=MCHPO1.IPCHP(1) NC1=MSOUP1.NOCOMP(/2) DO 22 M=1,NC1 DO 221 K=1,NC write(6,*)' ncomp1=',MSOUP1.NOCOMP(M),' ncomp=',NOCOMP(K) 221 CONTINUE 22 CONTINUE 21 CONTINUE C La composante %m1:4 n'existe pas pour le champ %m5:8 MOTERR(1:4)=' ' MOTERR(5:8)=' ' CALL ERREUR(77) RETURN ENDIF GO TO 10 11 CONTINUE IF(MLENTI.NE.0)SEGSUP MLENTI CALL ACTOBJ('CHPOINT ',MCHPOI,1) CALL ECROBJ('CHPOINT ',MCHPOI) RETURN 90 CONTINUE WRITE(6,*)' Arret anormal dans KCHT ' C Tache impossible. Probablement données erronées CALL ERREUR(26) END