Sources Esope | Cast3M

chdite
C CHDITE    SOURCE    CB215821  26/08/24    21:15:29     12622          
      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
      IPT2.ICOLOR(I)=IPT1.ICOLOR(I)
   10 CONTINUE
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 771 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
  771 CONTINUE
      SEGADJ MCOORD
 
      SEGSUP MTRAV
      SEGDES MCHPOI
 
      RETURN
      END