C CHASPG SOURCE CHAT 11/03/16 21:16:55 6902 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 CCOPTIO -INC SMMODEL -INC SMCHAML -INC SMELEME -INC SMINTE -INC SMCOORD LOGICAL FLAG1 CHARACTER*8 CHARIN 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 * * NBPGA1,NBPGAU DESIGNENT LES TAILLES MAX DES CHAMPS CH1 ET CH2 * N1PTE1,N1PTEL DESIGNENT LES TAILLES EFFECTIVES DE CES CHAMPS * SEGMENT INFO INTEGER INFELL(JG) ENDSEGMENT POINTEUR INFO1.INFO,INFO2.INFO 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) SEGACT MMODEL NSOUS1=KMODEL(/1) C C ACTIVATION DES MCHELM C MCHEL1 =IPOI1 SEGACT MCHEL1 NSOUS=MCHEL1.ICHAML(/1) IF(NSOUS.GT.NSOUS1)THEN IRET=553 SEGDES MMODEL,MCHEL1 RETURN ENDIF N1=NSOUS L1=MCHEL1.TITCHE(/1) N3=MCHEL1.INFCHE(/2) NINF=N3 IF (N3.LT.6) N3=6 SEGINI MCHELM TITCHE=MCHEL1.TITCHE IFOCHE=IFOUR IPOI2=MCHELM C C ON BOUCLE SUR LES SOUS-ZONES DU MCHAML C NTEL=0 KK1=0 DO 100 ISOUS=1,NSOUS * 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) SEGACT IMODEL IPMAIL=IMAMOD MELE=NEFMOD IF (IPLAC1.EQ.IPLAC) THEN SEGDES MMODEL,MCHEL1,MCHELM,IMODEL 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) 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(6,*)'Le SPG origine',LSPG(IPLAC1),'n''est pas compatible' WRITE(6,*)'avec ',LSPG(IPLAC) WRITE(6,*)'Seul le SPG SOMMET cible est authorisé !!!' SEGDES MMODEL,MCHEL1,MCHELM,IMODEL RETURN ENDIF SEGACT IPT1 IF(NSOUS.NE.1) THEN MELEME=IPT1.LISOUS(ISOUS) SEGACT MELEME ELSE MELEME=IPT1 ENDIF IMACHE(ISOUS)=MELEME C C MISE EN CONCORDANCE DES POINTEURS DE MAILLAGE C info=0 if(infmod(/1).lt.2+iplac) then CALL ELQUOI(MELE,0,IPLAC,IPTR2,IMODEL) IF ( IERR .NE. 0) GOTO 665 INFO=IPTR2 MELGEO=INFELL(14) MINTE=INFELL(11) 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 INFO1=0 IF(MINTE1.EQ.0)THEN if(infmod(/1).lt.2+iplac1) then CALL ELQUOI(MELE,0,IPLAC1,IPTR2,IMODEL) INFO1=IPTR2 MINTE1=INFO1.INFELL(11) ELSE minte1=infmod(2+iplac1) endif ENDIF SEGACT MINTE1 NBN1=MINTE1.SHPTOT(/2) SEGACT MINTE 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) SEGACT MCHAM1 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) SEGACT MELVA1 * * RECHERCHE DES TAILLES DU NOUVEAU CHAMELEM - dans le cas scalaire * N1PTE1=MELVA1.VELCHE(/1) N1EL1 =MELVA1.VELCHE(/2) N1PTEL=NBN2 N1EL =NEL * N2PTEL=0 N2EL=0 SEGINI MELVAL IELVAL(ICOMP)=MELVAL * * TRAITEMENT IMMEDIAT SI CHAMP ORIGINEL CONSTANT * IF(N1PTE1.EQ.1) THEN DO 4120 IEL=1,N1EL DO 4120 INO=1,NBN2 VELCHE(INO,IEL)=MELVA1.VELCHE(1,IEL) 4120 CONTINUE * 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 IRET=KERRE SEGDES MELVA1,MELEME,IMODEL,MCHAM1 SEGSUP SWORK,MCHAML,MELVAL GO TO 665 ENDIF * 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 IRET=KERRE SEGDES MELVA1,MELEME,IMODEL,MCHAM1 SEGSUP SWORK,MCHAML,MELVAL GO TO 665 ENDIF * DO 3123 IGAU=1,NBN2 VELCHE(IGAU,IEL)=VAL2(IGAU) 3123 CONTINUE ENDIF 3120 CONTINUE NTEL=NTEL+NEL ENDIF SEGDES MELVAL,MELVA1 180 CONTINUE SEGSUP SWORK SEGDES MCHAML,MCHAM1,IMODEL,IPT1 * IF(INFO.ne.0)SEGSUP INFO IF (MINTE.NE.0) SEGDES MINTE IF (MINTE1.NE.0) SEGDES MINTE1 IF (INFO1.NE.0) SEGSUP INFO1 IF (NSOUS.NE.1) SEGDES MELEME 100 CONTINUE 665 CONTINUE SEGDES MCHELM,MCHEL1 SEGDES MMODEL 666 CONTINUE RETURN END