Esope source files

   1 : C CHDITE    SOURCE    MAUGIS    07/07/06    21:15:02     5785           
   2 :       SUBROUTINE CHDITE(IPCH,IPT1,IPT2,ICPR,IARG,ISENS)
   3 : 
   4 : *PM   05/07/2007  
   5 : *     Il faut éviter de fermer accidentellement le maillage à transformer
   6 : *     si par malheur c'est le même que celui support du champ-point
   7 : 
   8 :       IMPLICIT INTEGER(I-N)
   9 :       implicit real*8 (a-h,o-z)
  10 : -INC CCOPTIO
  11 : -INC SMELEME
  12 : -INC SMCOORD
  13 : -INC SMCHPOI
  14 :       SEGMENT/MTRAV/(VA(max(2,NIN),NMIL),IPASS(KPOI))
  15 :       SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  16 :       CHARACTER*4 NAMEU(4),NOMIN(3)
  17 :       DATA NAMEU(1),NAMEU(2),NAMEU(3)/'UX  ','UY  ','UZ  '/
  18 :       DATA NAMEU(4)/'UR  '/
  19 : C
  20 :       SEGACT MCOORD
  21 :       NBSOUS=0
  22 :       NBREF=IPT1.LISREF(/1)
  23 :       IF (IARG.EQ.0) NBREF=0
  24 :       NBNN=IPT1.NUM(/1)
  25 :       NBELEM=IPT1.NUM(/2)
  26 :       SEGINI IPT2
  27 :       IPT2.ITYPEL=IPT1.ITYPEL
  28 :       DO 10 I=1,NBELEM
  29 :  10   IPT2.ICOLOR(I)=IPT1.ICOLOR(I)
  30 : C
  31 : C  ON FABRIQUE LA LISTE DES INCONNUES POSSIBLES
  32 : C
  33 :       NIN=IDIM
  34 :       NMIL=XCOOR(/1)/(IDIM+1)
  35 :       IF(IFOMOD.NE.0) THEN
  36 :       NOMIN(1)=NAMEU(1)
  37 :       NOMIN(2)=NAMEU(2)
  38 :       IF(IDIM.EQ.3) NOMIN(3)=NAMEU(3)
  39 :       ENDIF
  40 :       IF(IFOMOD.EQ.0) THEN
  41 :       NOMIN(1)=NAMEU(4)
  42 :       NOMIN(2)=NAMEU(3)
  43 :       ENDIF
  44 : C
  45 : C  ON RECUPERE LE CHPOINT
  46 : C
  47 :       MCHPOI=IPCH
  48 :       SEGACT MCHPOI
  49 : C
  50 :       KPOI=0
  51 :       DO 1 I = 1,IPCHP(/1)
  52 :       MSOUPO=IPCHP(I)
  53 :       SEGACT MSOUPO
  54 :       KPOI1=NOCOMP(/2)
  55 :       KPOI=MAX(KPOI,KPOI1)
  56 :       SEGDES MSOUPO
  57 :     1 CONTINUE
  58 : C
  59 :       SEGINI MTRAV
  60 :       DO 70 I=1,IPCHP(/1)
  61 :       MSOUPO=IPCHP(I)
  62 :       SEGACT MSOUPO
  63 :       JCOMP=0
  64 :       DO 71 K=1,NOCOMP(/2)
  65 :       IPASS(K)=0
  66 :       DO 710 KN=1,NIN
  67 :       IF(NOMIN(KN).EQ.NOCOMP(K)) GO TO 73
  68 :  710  CONTINUE
  69 :       GO TO 71
  70 :    73 CONTINUE
  71 :       IPASS(K)=KN
  72 :       JCOMP=JCOMP+1
  73 :    71 CONTINUE
  74 :       IF(JCOMP.EQ.0) GO TO 770
  75 :       MELEME=IGEOC
  76 :       SEGACT MELEME
  77 :       MPOVAL=IPOVAL
  78 :       SEGACT MPOVAL
  79 :       DO 78 K=1,NUM(/2)
  80 :       K2= NUM(1,K)
  81 :       IF(K2.EQ.0) GO TO 78
  82 :       DO 74 KK=1,NOCOMP(/2)
  83 :       K1=IPASS(KK)
  84 :       IF(K1.EQ.0) GO TO 74
  85 :       VA(K1,K2)=VPOCHA(K,KK)
  86 :    74 CONTINUE
  87 :    78 CONTINUE
  88 :       SEGDES MPOVAL
  89 : *PM
  90 :       IF(MELEME.NE.IPT1) SEGDES MELEME
  91 :  770  SEGDES MSOUPO
  92 :    70 CONTINUE
  93 : *
  94 :       NBPTB=XCOOR(/1)/(IDIM+1)
  95 :       NBPTS=NBPTB+NBNN*NBELEM
  96 :       SEGADJ MCOORD
  97 :       NBPTS=NBPTB
  98 :       DO 11 J=1,NBELEM
  99 :       DO 11 I=1,NBNN
 100 :       IF (ICPR(IPT1.NUM(I,J)).NE.0) GOTO 3
 101 :       IREF=IPT1.NUM(I,J)*(IDIM+1)
 102 :       XCOOR(NBPTS*(IDIM+1)+1)=VA(1,IPT1.NUM(I,J))*ISENS
 103 :      .                        +XCOOR(IREF-IDIM)
 104 :       XCOOR(NBPTS*(IDIM+1)+2)=VA(2,IPT1.NUM(I,J))*ISENS
 105 :      .                        +XCOOR(IREF-IDIM+1)
 106 :       IF (IDIM.GE.3) XCOOR(NBPTS*(IDIM+1)+3)=VA(3,IPT1.NUM(I,J))*ISENS
 107 :      .              +XCOOR(IREF-IDIM+2)
 108 :       XCOOR(NBPTS*(IDIM+1)+(IDIM+1))=XCOOR(IREF)
 109 :       NBPTS=NBPTS+1
 110 :       IPT2.NUM(I,J)=NBPTS
 111 :       ICPR(IPT1.NUM(I,J))=IPT2.NUM(I,J)
 112 :       GOTO 11
 113 :    3  IPT2.NUM(I,J)=ICPR(IPT1.NUM(I,J))
 114 :   11  CONTINUE
 115 :       SEGADJ MCOORD
 116 : *
 117 :       SEGSUP MTRAV
 118 :       SEGDES MCHPOI
 119 :       RETURN
 120 :       END
 121 : 
 122 : 
 123 :