Esope source files

   1 : C PROCHP    SOURCE    PV        13/04/12    21:15:46     7756           
   2 : 
   3 : C=======================================================================
   4 : C  Sous programme appele par PROPER et DEDU1
   5 : C  Creation du CHPOINT MCHPO4 de deplacement du MAILLAGE elementaire
   6 : C  IPT1 vers le MAILLAGE elementaire IPT2
   7 : C  11/1997 : KICH
   8 : C  10/2003 : Modifications pour integration du cas IDIM=1
   9 : C=======================================================================
  10 : 
  11 :       SUBROUTINE PROCHP (IPT1,IPT2,MCHPO4,IP1)
  12 : 
  13 :       IMPLICIT INTEGER(I-N)
  14 :       IMPLICIT REAL*8 (A-H,O-Z)
  15 : 
  16 : -INC CCOPTIO
  17 : -INC SMCOORD
  18 : -INC SMELEME
  19 : -INC CCGEOME
  20 : -INC SMCHPOI
  21 : 
  22 :       SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  23 :       SEGMENT ICP1(XCOOR(/1)/(IDIM+1))
  24 : 
  25 :       idimp1=IDIM+1
  26 : 
  27 :       ICP1=IP1
  28 : C  Determination des noeuds supports du CHPOINT
  29 :       SEGINI,IPT3=IPT1
  29 :       CALL CHANGE(IPT3,1)
  30 :       SEGINI,IPT4=IPT2
  30 :       CALL CHANGE(IPT4,1)
  31 : 
  32 : C  Initialisation du CHPOINT de nature DISCRETE sur un unique MAILLAGE
  33 :       NSOUPO=1
  34 :       NAT=2
  35 :       SEGINI,MCHPO4
  36 :       MCHPOI=MCHPO4
  37 :       JATTRI(1)=1
  38 :       MTYPOI='DEPLACEM'
  39 :       MOCHDE='CHAMP CREE PAR PROPER'
  40 :       IFOPOI=IFOUR
  41 :       NC=IDIM
  42 :       SEGINI,MSOUP5
  43 :       IPCHP(1)=MSOUP5
  44 :       MSOUPO=MSOUP5
  45 :       SEGDES,MCHPO4
  46 :       IF (IFOMOD.EQ.3) THEN
  47 :         NOCOMP(1)='UX  '
  48 :       ELSE IF (IFOMOD.EQ.4.OR.IFOMOD.EQ.5) THEN
  49 :         NOCOMP(1)='UR  '
  50 :       ELSE IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.1) THEN
  51 :         NOCOMP(1)='UR  '
  52 :         NOCOMP(2)='UZ  '
  53 :       ELSE
  54 :         NOCOMP(1)='UX  '
  55 :         NOCOMP(2)='UY  '
  56 :         IF (NC.GE.3) NOCOMP(3)='UZ  '
  57 :       ENDIF
  58 :       DO i=1,NC
  59 :         NOCONS(i)=' '
  60 :         NOHARM(i)=NIFOUR
  61 :       ENDDO
  62 :       IGEOC=IPT3
  63 :       N=IPT3.NUM(/2)
  64 :       SEGINI,MPOVA5
  65 :       MPOVAL=MPOVA5
  66 :       IPOVAL=MPOVA5
  67 :       SEGDES,MSOUP5
  68 : C  Calcul des valeurs du CHPOINT
  69 :       SEGACT,IPT4,IPT3
  70 :       SEGACT,MCOORD
  71 :       SEGACT,ICP1*MOD
  72 :       DO i=1,N
  73 :         IF (ICP1(IPT3.NUM(1,i)).EQ.0) THEN
  74 :           ICP1(IPT3.NUM(1,i))=IPT4.NUM(1,i)
  75 :         ELSE IF (ICP1(IPT3.NUM(1,i)).NE.IPT4.NUM(1,i)) THEN
  76 :           GOTO 800
  77 :         ENDIF
  78 :         IREF4=(IPT4.NUM(1,i)-1)*idimp1
  79 :         IREF3=(IPT3.NUM(1,i)-1)*idimp1
  80 :         DO j=1,NC
  81 :           VPOCHA(i,j)=XCOOR(IREF4+j)-XCOOR(IREF3+j)
  82 :         ENDDO
  83 :       ENDDO
  84 :       SEGDES,MPOVA5,ICP1,IPT3
  85 :       RETURN
  86 : 
  87 : C  Erreur dans le calcul du CHPOINT, incompatibilite entre les maillages
  88 :  800  SEGSUP,MPOVA5,MSOUP5,MCHPO4,IPT3
  89 :       SEGDES,ICP1
  89 :       CALL ERREUR (878)
  90 :       RETURN
  91 : 
  92 :       END
  93 : 
  94 :  
  95 :  
  96 :  
  97 :  
  98 :