C CHDITE SOURCE CB215821 20/11/25 13:19:23 10792 SUBROUTINE CHDITE(IPCH,IPT1,IPT2,ICPR,IARG,ISENS) *PM 05/07/2007 * Il faut éviter de fermer accidentellement le maillage à transformer * si par malheur c'est le même que celui support du champ-point IMPLICIT INTEGER(I-N) implicit real*8 (a-h,o-z) -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMCOORD -INC SMCHPOI SEGMENT/MTRAV/(VA(max(2,NIN),NMIL),IPASS(KPOI)) SEGMENT ICPR(nbpts) CHARACTER*(LOCOMP) NAMEU(4),NOMIN(3) DATA NAMEU(1),NAMEU(2),NAMEU(3)/'UX ','UY ','UZ '/ DATA NAMEU(4)/'UR '/ SEGACT MCOORD*mod NBSOUS=0 NBREF=IPT1.LISREF(/1) IF (IARG.EQ.0) NBREF=0 NBNN=IPT1.NUM(/1) NBELEM=IPT1.NUM(/2) SEGINI IPT2 IPT2.ITYPEL=IPT1.ITYPEL DO 10 I=1,NBELEM 10 IPT2.ICOLOR(I)=IPT1.ICOLOR(I) C C ON FABRIQUE LA LISTE DES INCONNUES POSSIBLES C C Cas 3D : IF (IFOMOD.EQ.2) THEN NOMIN(1) = NAMEU(1) NOMIN(2) = NAMEU(2) NOMIN(3) = NAMEU(3) C Cas 2D PLAN : ELSE IF (IFOMOD.EQ.-1) THEN NOMIN(1) = NAMEU(1) NOMIN(2) = NAMEU(2) C Cas 2D AXIS/ FOUR : ELSE IF (IFOMOD.EQ.0 .OR. IFOMOD.EQ.1) THEN NOMIN(1) = NAMEU(4) NOMIN(2) = NAMEU(3) C Cas 1D PLAN : ELSE IF (IFOMOD.EQ.3) THEN NOMIN(1) = NAMEU(1) C Cas 1D AXIS / SPHE : ELSE IF (IFOMOD.EQ.4 .OR. IFOMOD.EQ.5) THEN NOMIN(1) = NAMEU(4) C Cas Frequentiel ??? ELSE IF (IFOMOD.EQ.6) THEN NOMIN(1) = NAMEU(1) NOMIN(2) = NAMEU(2) IF (IDIM.EQ.3) NOMIN(3) = NAMEU(3) C Autres cas : non prevus ! ELSE CALL ERREUR(5) RETURN ENDIF C C ON RECUPERE LE CHPOINT C MCHPOI=IPCH SEGACT MCHPOI C KPOI=0 DO 1 I = 1,IPCHP(/1) MSOUPO=IPCHP(I) SEGACT MSOUPO KPOI1=NOCOMP(/2) KPOI=MAX(KPOI,KPOI1) ** SEGDES MSOUPO 1 CONTINUE NMIL = nbpts NIN = IDIM SEGINI MTRAV DO 70 I=1,IPCHP(/1) MSOUPO=IPCHP(I) ** SEGACT MSOUPO JCOMP=0 DO 71 K=1,NOCOMP(/2) IPASS(K)=0 DO 710 KN=1,NIN IF(NOMIN(KN).EQ.NOCOMP(K)) GO TO 73 710 CONTINUE GO TO 71 73 CONTINUE IPASS(K)=KN JCOMP=JCOMP+1 71 CONTINUE IF(JCOMP.EQ.0) GO TO 770 MELEME=IGEOC SEGACT MELEME MPOVAL=IPOVAL SEGACT MPOVAL DO 78 K=1,NUM(/2) K2= NUM(1,K) IF(K2.EQ.0) GO TO 78 DO 74 KK=1,NOCOMP(/2) K1=IPASS(KK) IF(K1.EQ.0) GO TO 74 VA(K1,K2)=VPOCHA(K,KK) 74 CONTINUE 78 CONTINUE SEGDES MPOVAL *PM IF(MELEME.NE.IPT1) SEGDES MELEME 770 SEGDES MSOUPO 70 CONTINUE * NBPTB=nbpts NBPTS=NBPTB+NBNN*NBELEM SEGADJ MCOORD NBPTS=NBPTB DO 11 J=1,NBELEM DO 11 I=1,NBNN IF (ICPR(IPT1.NUM(I,J)).NE.0) GOTO 3 IREF=IPT1.NUM(I,J)*(IDIM+1) XCOOR(NBPTS*(IDIM+1)+1) . = VA(1,IPT1.NUM(I,J))*ISENS + XCOOR(IREF-IDIM) XCOOR(NBPTS*(IDIM+1)+2) . = VA(2,IPT1.NUM(I,J))*ISENS + XCOOR(IREF-IDIM+1) IF (IDIM.GE.3) XCOOR(NBPTS*(IDIM+1)+3) . = VA(3,IPT1.NUM(I,J))*ISENS+XCOOR(IREF-IDIM+2) XCOOR(NBPTS*(IDIM+1)+(IDIM+1))=XCOOR(IREF) NBPTS=NBPTS+1 IPT2.NUM(I,J)=NBPTS ICPR(IPT1.NUM(I,J))=IPT2.NUM(I,J) GOTO 11 3 IPT2.NUM(I,J)=ICPR(IPT1.NUM(I,J)) 11 CONTINUE SEGADJ MCOORD SEGSUP MTRAV SEGDES MCHPOI RETURN END