C KCHAM1 SOURCE MB234859 25/09/08 21:15:45 12358 SUBROUTINE KCHAM1(IPMODL,IPCHPO,IPCHEL) C____________________________________________________________________* C * C transformation de chpoint en mchaml * C * C entr{es: * C ________ * C * C ipmodl pointeur sur un mmodel * C ipchpo pointeur sur le chpoint * C * C sorties: * C ________ * C * C ipchel pointeur sur le mchaml resultat * C____________________________________________________________________* C * IMPLICIT REAL*8 (A-H,O-Z) C -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMCOORD -INC SMCHAML -INC SMCHPOI -INC SMMODEL -INC SMELEME -INC SMLENTI -INC SMINTE C C C PARAMETER (NSPG = 9) PARAMETER (NSPG = 5) CHARACTER*8 LSPG(NSPG) CHARACTER*(NCONCH) CONM CHARACTER*8 SOUTYP,TYPSPG C C l'ordre des SPG correspond à l'ordre du KPOIND C LSPG(1)='NOEUD' -> SOMMET C LSPG(2)='GRAVITE' -> CENTRE C LSPG(3)='RIGIDITE' C LSPG(4)='MASSE' C LSPG(5)='STRESSES' C LSPG(6)='THERMIQU' C LSPG(7)='FACE' -> FACE C LSPG(8)='P1CENTRE' -> CENTREP1 C LSPG(9)='MSOMMET' -> MSOMMET LSPG(1)='SOMMET' LSPG(2)='CENTRE' LSPG(3)='FACE' LSPG(4)='CENTREP1' LSPG(5)='MSOMMET' C C le traitement d'harmoniques de fourier n'est pas implemente C C IPMINT=0 IPCHEL=0 C NPINT = 0 C IRRT=0 CONM=' ' TYPSPG=' ' C C activation de l'objet modele C MMODEL = IPMODL CALL LEKMOD(MMODEL,IDOMA,INEFMD) IF(IERR.NE.0)GOTO 9999 SEGACT,MMODEL C IDOMA correspond au pointeur de la table domaine C C activation du chpoint C MCHPOI=IPCHPO SEGACT,MCHPOI NSOUPO=IPCHP(/1) C C Determination du type de support geometrique C DO 20 I=1,NSOUPO MSOUPO=IPCHP(I) SEGACT MSOUPO MLMCHP=IGEOC SEGDES MSOUPO CALL KRIPAD(MLMCHP,MLENTI) C C TYPSPG = SOMMET, FACE, CENTRE, CENTREP0, CENTREP1 ou MSOMMET C DO 10 L=1,NSPG TYPSPG=LSPG(L) CALL LEKTAB(IDOMA,TYPSPG,MLMSPG) CALL KRIPAD(MLMSPG,MLENT1) IF(IERR.NE.0)GOTO 9999 CALL VERPAD(MLENTI,MLMSPG,IRET1) CALL VERPAD(MLENT1,MLMCHP,IRET2) IF(IRET1.EQ.0.AND.IRET2.EQ.0) GOTO 21 10 CONTINUE 20 CONTINUE WRITE(6,*)'SPG du champoint non trouve : ' WRITE(6,*)'CHPO peut-etre incompatible avec le modele?' GOTO 666 21 CONTINUE IPT3=MLMSPG INFSPG=L IF(L.GE.3) INFSPG=4+L IF(INFSPG.EQ.2) SEGACT,IPT3 C C recherche eventuelle des sous-domaine du maillage C associe a l'objet modele Navier-Stokes C IMACR1=0 DO 11 I=1,MAX(1,KMODEL(/1)) IMODEL=KMODEL(I) SEGACT,IMODEL NELE=NEFMOD IF(NELE.GE.216.AND.NELE.LE.222) IMACR1=IMACR1+1 11 CONTINUE CALL LEKTAB(IDOMA,'MAILLAGE',MPERE) IF(INEFMD.EQ.2.AND.INFSPG.NE.2) THEN CALL LEKTAB(IDOMA,'MACRO1',MPERE) ENDIF IF(IMACR1.EQ.KMODEL(/1)) CALL LEKTAB(IDOMA,'MAILLAGE',MPERE) C LINE ou LINB avec CENTREP1 IF(INEFMD.EQ.1.OR.INEFMD.EQ.4) THEN IF(INFSPG.EQ.8) THEN C Option %m1:8 incompatible avec les données MOTERR( 1: 8) = TYPSPG CALL ERREUR(803) GOTO 666 ENDIF ENDIF C Face IF(INFSPG.EQ.7) THEN C Option %m1:8 incompatible avec les données MOTERR( 1: 8) = TYPSPG CALL ERREUR(803) GOTO 666 ENDIF IF(INFSPG.EQ.8) THEN CALL LEKTAB(IDOMA,'ELTP1NC',IPT4) SEGACT,IPT4 ENDIF MELEME=MPERE SEGACT MELEME N1=MAX(1,LISOUS(/1)) C C initialisation du segment descripteur du champ par element C N3=6 L1=LEN(MTYPOI) SOUTYP=MTYPOI SEGINI,MCHELM TITCHE=SOUTYP IFOCHE=IFOUR C C remplissage des MCHAML C ILM1=0 DO 30 I=1,N1 IF(N1.NE.1) THEN IPT1=LISOUS(I) SEGACT IPT1 ELSE IPT1=MELEME ENDIF IMACHE(I)=IPT1 CONCHE(I)=CONM INFCHE(I,6)=INFSPG IMODEL=KMODEL(I) SEGACT,IMODEL NELE=NEFMOD N2PTEL=0 N2EL=0 C TYPE SPG DU CHPO : SOMMET IF(INFSPG.EQ.1) THEN IMINT=0 N1PTEL=IPT1.NUM(/1) C TYPE SPG DU CHPO : CENTRE ELSEIF(INFSPG.EQ.2) THEN IMINT=infmod(INFSPG+2) N1PTEL=1 C TYPE SPG DU CHPO : CENTREP1 ELSEIF(INFSPG.EQ.8) THEN CALL ELQUOI(IMODEL,INFSPG,IPTR) IMINT=IPTR MINTE=IMINT N1PTEL=MINTE.SHPTOT(/2) C TYPE SPG DU CHPO : MSOMMET ELSEIF(INFSPG.EQ.9) THEN CALL ELQUOI(IMODEL,INFSPG,IPTR) IMINT=IPTR MINTE=IMINT N1PTEL=MINTE.SHPTOT(/2) ENDIF N1EL=IPT1.NUM(/2) INFCHE(I,4)=IMINT DO 40 J=1,NSOUPO MSOUPO=IPCHP(J) SEGACT MSOUPO N2=NOCOMP(/2) IPT2=IGEOC SEGACT,IPT2 CALL KRIPAD(IPT2,MLENT2) SEGACT,MLENT2 MPOVAL=IPOVAL SEGACT,MPOVAL SEGINI,MCHAML ICHAML(I)=MCHAML DO 50 K=1,N2 NOMCHE(K)=NOCOMP(K) TYPCHE(K)='REAL*8' SEGINI,MELVAL IELVAL(K)=MELVAL DO 70 K70=1,N1EL DO 80 K80=1,N1PTEL IF(INFSPG.EQ.1) THEN II2=IPT1.NUM(K80,K70) ELSEIF(INFSPG.EQ.2) THEN II2=IPT3.NUM(K80,(ILM1+K70)) ELSEIF(INFSPG.EQ.8) THEN II2=IPT4.NUM(K80,(ILM1+K70)) ELSEIF(INFSPG.EQ.9) THEN IF(INEFMD.EQ.1) II1=K80 IF(INEFMD.EQ.2) II1=(2*K80)-1 IF(INEFMD.EQ.3) II1=(2*K80)-1 IF(INEFMD.EQ.4) II1=K80 II2=IPT1.NUM(II1,K70) ENDIF VELCHE(K80,K70)=VPOCHA(MLENT2.LECT(II2),K) 80 CONTINUE 70 CONTINUE SEGDES,MELVAL 50 CONTINUE SEGDES,IPT2 SEGDES,MLENT2 SEGDES,MSOUPO SEGDES,MPOVAL SEGDES,MCHAML 40 CONTINUE ILM1=ILM1+IPT1.NUM(/2) IF(N1.NE.1) SEGDES,IPT1 SEGDES,IMODEL 30 CONTINUE IPCHEL=MCHELM SEGDES,MCHELM SEGDES,MELEME 666 CONTINUE IF(INFSPG.EQ.2) SEGDES,IPT3 IF(INFSPG.EQ.8) SEGDES,IPT4 SEGDES,MCHPOI SEGDES,MMODEL C 9999 CONTINUE RETURN END