C CHASPG SOURCE MB234859 26/06/04 21:15:11 12564 SUBROUTINE CHASPG(IPMODL,IPOI1,IPOI2,IRET,IPLAC) C--------------------------------------------------------------------- C C ENTREES: C C IPMODL Pointeur sur un MMODEL de type NAVIER_STOKES C IPOI1 Pointeur sur un MCHAML C IPLAC Indique le type de support demandé : C 1 scalaire aux NOEUDS C 2 scalaire au CENTRE DE GRAVITE C 3 scalaire aux points d'integration de la RAIDEUR C 4 scalaire aux points d'integration de la MASSE C 5 scalaire aux points de CONTRAINTES C 6 (utilisé dans le cas de la thermique) C 7 SPG : FACE C 8 SPG : CENTREP1 C 9 SPG : MSOMMET C TYPPROJ Mot designant le type transformation autre-->sommet C INTERP pour interpolation C PROJEC pour projection C C SORTIE: C C IPOI2 Pointeur sur un MCHAML C IRET =0 Si tout est ok C Sinon contient le numero d'erreur C C A.BLEYER le 22/01/2004 C C--------------------------------------------------------------------- IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMMODEL -INC SMCHAML -INC SMELEME -INC SMINTE -INC SMCOORD PARAMETER (NSPG = 9) CHARACTER*8 LSPG(NSPG) C SEGMENT SWORK REAL*8 VAL1(NBN1),VAL2(NBN2),VALN(NBN2) REAL*8 SHP1(6,NBN1),SHP2(6,NBN2),XE(3,NBNN) ENDSEGMENT C C NBPGA1,NBPGAU DESIGNENT LES TAILLES MAX DES CHAMPS CH1 ET CH2 C N1PTE1,N1PTEL DESIGNENT LES TAILLES EFFECTIVES DE CES CHAMPS C IRET=0 LSPG(1)='NOEUD' LSPG(2)='GRAVITE' LSPG(3)='RIGIDITE' LSPG(4)='MASSE' LSPG(5)='STRESSES' LSPG(6)='THERMIQU' LSPG(7)='FACE' LSPG(8)='P1CENTRE' LSPG(9)='MSOMMET' C C ACTIVATION DU MODELE C MMODEL=IPMODL CALL LEKMOD(MMODEL,IDOMA,INEFMD) NSOUS1=KMODEL(/1) C C ACTIVATION DES MCHELM C MCHEL1 =IPOI1 NSOUS=MCHEL1.ICHAML(/1) IF(NSOUS.GT.NSOUS1)THEN IRET=553 RETURN ENDIF N1=NSOUS L1=MCHEL1.TITCHE(/1) N3=MCHEL1.INFCHE(/2) IF (N3.NE.6) then write(ioimp,*) 'CHASPG : infche(/2) = N3 != 6' call erreur(5) endif NINF=N3 SEGINI MCHELM TITCHE=MCHEL1.TITCHE IFOCHE=IFOUR IPOI2=MCHELM C C ON BOUCLE SUR LES SOUS-ZONES DU MCHAML C C NTEL=0 C KK1=0 SEGACT,MCOORD DO 100 ISOUS=1,NSOUS C CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) DO 191 IP=1,NINF INFCHE(ISOUS,IP)=MCHEL1.INFCHE(ISOUS,IP) 191 CONTINUE MINTE1=MCHEL1.INFCHE(ISOUS,4) IPLAC1=MCHEL1.INFCHE(ISOUS,6) IMODEL=KMODEL(ISOUS) MELE=NEFMOD IF (IPLAC1.EQ.IPLAC) THEN IPOI2=IPOI1 RETURN ELSEIF (IPLAC1.EQ.1.AND.IPLAC1.NE.IPLAC) THEN IF (IPLAC.EQ.2) THEN CALL LEKTAB(IDOMA,'MAILLAGE',IPT1) ELSEIF(IPLAC.EQ.8) THEN IF (MELE.GE.223.AND.MELE.LE.236) THEN CALL LEKTAB(IDOMA,'MACRO1',IPT1) ELSE CALL LEKTAB(IDOMA,'MAILLAGE',IPT1) ENDIF CALL LEKTAB(IDOMA,'ELTP1NC',IPT2) C KK1=1 ELSEIF(IPLAC.EQ.9) THEN IF (MELE.GE.223.AND.MELE.LE.236) THEN CALL LEKTAB(IDOMA,'MACRO1',IPT1) ELSE CALL LEKTAB(IDOMA,'MAILLAGE',IPT1) ENDIF ENDIF ELSEIF (IPLAC1.NE.1.AND.IPLAC.EQ.1) THEN IF (MELE.GE.223.AND.MELE.LE.236) THEN CALL LEKTAB(IDOMA,'MACRO1',IPT1) ELSE CALL LEKTAB(IDOMA,'MAILLAGE',IPT1) ENDIF ELSEIF (IPLAC1.NE.1.AND.IPLAC.NE.1) THEN write(ioimp,*) 'IPLAC1,IPLAC=',IPLAC1,IPLAC WRITE(6,*)'Le SPG origine',LSPG(IPLAC1),'n''est pas compatible' WRITE(6,*)'avec ',LSPG(IPLAC) WRITE(6,*)'Seul le SPG SOMMET cible est authorisé !!!' MOTERR(1:8)='CHASPG ' IRET=1127 RETURN ENDIF CALL ACTOBJ('MAILLAGE',IPT1,1) IF(IERR .NE. 0)RETURN IF(NSOUS.NE.1) THEN MELEME=IPT1.LISOUS(ISOUS) ELSE MELEME=IPT1 ENDIF IMACHE(ISOUS)=MELEME C C MISE EN CONCORDANCE DES POINTEURS DE MAILLAGE C if(infmod(/1).lt.2+iplac) then CALL ELQUOI(IMODEL,IPLAC,IPTR2) IF ( IERR .NE. 0) GOTO 665 MELGEO=INFELE(14) MINTE=IPTR2 ELSE MINTE=infmod(2+iplac) MELGEO=INFELE(14) ENDIF INFCHE(ISOUS,4)=MINTE IF(IPLAC.EQ.1)INFCHE(ISOUS,4)=0 INFCHE(ISOUS,6)=IPLAC C C ON RECUPERE LE NOMBRE D ELEMENTS C NBNN =NUM(/1) NEL =NUM(/2) C WRITE(6,*)'NBNN=',NBNN,'NEL=',NEL C C ON RECUPERE LE NOMBRE DE POINTS SUPPORT C NBPGA1 POUR L'ANCIEN CHAMP ET NBPGAU POUR LE NOUVEAU C IF(MINTE1.EQ.0)THEN CALL ELQUOI(IMODEL,IPLAC1,IPTR2) MINTE1=IPTR2 ENDIF NBN1=MINTE1.SHPTOT(/2) NBN2=SHPTOT(/2) IF(IPLAC.EQ.2) NBN2=1 C WRITE(6,*)'NBN1=',NBN1,'NBN2=',NBN2 SEGINI SWORK C C CREATION DU MCHAML C MCHAM1=MCHEL1.ICHAML(ISOUS) N2=MCHAM1.NOMCHE(/2) SEGINI MCHAML ICHAML(ISOUS)=MCHAML C C BOUCLE SUR LES COMPOSANTES C DO 180 ICOMP=1,N2 C NOMCHE(ICOMP)=MCHAM1.NOMCHE(ICOMP) TYPCHE(ICOMP)=MCHAM1.TYPCHE(ICOMP) C MELVA1=MCHAM1.IELVAL(ICOMP) C C RECHERCHE DES TAILLES DU NOUVEAU CHAMELEM - dans le cas scalaire C N1PTE1=MELVA1.VELCHE(/1) N1EL1 =MELVA1.VELCHE(/2) N1PTEL=NBN2 N1EL =NEL C N2PTEL=0 N2EL=0 SEGINI MELVAL IELVAL(ICOMP)=MELVAL C C TRAITEMENT IMMEDIAT SI CHAMP ORIGINEL CONSTANT C IF(N1PTE1.EQ.1) THEN DO 4120 IEL=1,N1EL XFLO=MELVA1.VELCHE(1,IEL) DO 41201 INO=1,NBN2 VELCHE(INO,IEL)=XFLO 41201 CONTINUE 4120 CONTINUE C ELSE DO 3120 IEL=1,NEL DO 3121 IGAU=1,NBN1 VAL1(IGAU)=MELVA1.VELCHE(IGAU,IEL) 3121 CONTINUE C C LE CHAMELEM 1 EST AUX NOEUDS ET ON VEUT CHANGER DE SPG C IF(IPLAC1.EQ.1) THEN CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE) CALL QUEDIM(MELGEO,KERRE) CALL K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN, > SWORK,1,KERRE) IF(KERRE.NE.0) THEN IF (KERRE.EQ.195) INTERR(1)=IEL IRET=KERRE SEGSUP SWORK,MCHAML,MELVAL GO TO 665 ENDIF C DO 3122 IGAU=1,NBN2 VELCHE(IGAU,IEL)=VAL2(IGAU) 3122 CONTINUE C C PASSAGE D'UN SPG QUELCONQUE VERS UN CHAMELEM AUX NOEUDS C ELSEIF(IPLAC1.NE.1.AND.IPLAC.EQ.1) THEN CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE) CALL QUEDIM(MELGEO,KERRE) CALL K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN, > SWORK,2,KERRE) IF(KERRE.NE.0) THEN IF (KERRE.EQ.195) INTERR(1)=IEL IRET=KERRE SEGSUP SWORK,MCHAML,MELVAL GO TO 665 ENDIF C DO 3123 IGAU=1,NBN2 VELCHE(IGAU,IEL)=VAL2(IGAU) 3123 CONTINUE ENDIF 3120 CONTINUE C NTEL=NTEL+NEL ENDIF 180 CONTINUE SEGSUP SWORK C 100 CONTINUE SEGDES,MCOORD 665 CONTINUE C CONTINUE RETURN END