Esope source files

   1 : C ENLEV5    SOURCE    PV        13/04/11    21:15:44     7755           
   2 :       SUBROUTINE ENLEV5(IPOIN1,MSWMIL,IPOIN2)
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8(A-H,O-Z)
   5 : -INC CCOPTIO
   6 : -INC SMCHPOI
   7 : -INC SMCOORD
   8 : -INC SMELEME
   9 : -INC TMTRAV
  10 :       SEGMENT MSWMIL
  11 :       CHARACTER*4 MOTDDL(IAAA)
  12 :       ENDSEGMENT
  13 :       SEGMENT/MTRA/(ICPR(XCOOR(/1)/(IDIM+1)))
  14 :       SEGMENT MTR1
  15 :       CHARACTER*4 IPCOM(0)
  16 :       ENDSEGMENT
  17 :       SEGMENT/MTR2/(IPHAR(0))
  18 : C     
  19 :       SEGACT MSWMIL
  20 :       IBDDL=MOTDDL(/2)
  21 :       IF(IBDDL.EQ.0) THEN
  22 :          IPOIN2=IPOIN1
  23 :          RETURN
  24 :       ENDIF
  25 :       IF(IBDDL.EQ.1) THEN
  26 :          MCHPOI=IPOIN1
  27 :          SEGACT MCHPOI
  28 :          NSOUPO=IPCHP(/1)
  29 :          ITOT=0
  30 :          ISOU=0
  31 :          DO 4 IA=1,NSOUPO
  32 :             MSOUPO=IPCHP(IA)
  33 :             SEGACT MSOUPO
  34 :             NCBBB=NOCOMP(/2)
  35 :             IEXT=0
  36 :             DO 5 IB=1,NCBBB
  37 :                IF(NOCOMP(IB).EQ.MOTDDL(1)) THEN
  38 :                   IEXT=IA
  39 :                   ITOT=ITOT+1
  40 :                ENDIF
  41 :  5          CONTINUE
  42 :  4       CONTINUE
  43 :          IF(ITOT.NE.1)    GO TO 2876
  44 :          IF(IEXT.EQ.0)    GO TO 2876
  45 :          MSOUPO=IPCHP(IEXT)
  46 :          IF(NOCOMP(/2).NE.1) GO TO 2876
  47 :          NSOUPO=NSOUPO-1
  48 :          NC=IBDDL
  49 :          NAT=MAX ( JATTRI(/1) , 1)
  50 :          SEGINI MCHPO1
  51 :          MCHPO1.MTYPOI=MTYPOI
  52 :          MCHPO1.MOCHDE=MOCHDE
  53 :          IF ( JATTRI(/1) .GE. 1 ) THEN
  54 :             MCHPO1.JATTRI(1) = JATTRI(1)
  55 :          ELSE
  56 :             MCHPO1.JATTRI(1) = 0
  57 :          ENDIF
  58 :          MCHPO1.IFOPOI=IFOPOI
  59 :          IBB=0
  60 :          DO 7 IA=1,IPCHP(/1)
  61 :             MSOUPO=IPCHP(IA)
  62 :             IF ( IEXT.EQ.IA) THEN
  63 :                SEGDES MSOUPO
  64 :             ELSE
  65 :                SEGINI,MSOUP1=MSOUPO
  66 :                IBB=IBB+1
  67 :                IPT1=IGEOC
  68 :                SEGACT IPT1
  69 : **             SEGINI,MELEME=IPT1
  70 :                MELEME=IPT1
  71 :                MPOVAL=IPOVAL
  72 :                SEGACT MPOVAL
  73 :                SEGINI,MPOVA1=MPOVAL
  74 :                MSOUP1.IGEOC=MELEME
  75 :                MSOUP1.IPOVAL=MPOVA1
  76 :                SEGDES MPOVA1,MPOVAL,MSOUP1,MSOUPO,MELEME,IPT1
  77 :                MCHPO1.IPCHP(IBB)=MSOUP1
  78 :             ENDIF
  79 :  7       CONTINUE
  80 :          IPOIN2 = MCHPO1
  81 :          SEGDES MCHPO1,MCHPOI
  82 :          RETURN
  83 :       ENDIF
  84 :  2876 CONTINUE
  85 : C     
  86 :       SEGINI MTRA,MTR1,MTR2
  87 : C     
  88 :       NC=0
  89 :       IK=0
  90 :       MCHPOI=IPOIN1
  91 :       SEGACT MCHPOI
  92 :       NSOUPO=IPCHP(/1)
  93 : C     
  94 : C     BOUCLE SUR LES SOUS REFERENCES DU CHPOINT
  95 : C     
  96 :       DO 350 IA=1,NSOUPO
  97 :          MSOUPO=IPCHP(IA)
  98 :          SEGACT MSOUPO
  99 :          NCBBB=NOCOMP(/2)
 100 :          MILCO=0
 101 : C     
 102 :          DO 330 IB=1,NCBBB
 103 :             DO 344 MIK=1,IBDDL
 104 :                IF(NOCOMP(IB).EQ.MOTDDL(MIK)) GO TO 330
 105 :  344        CONTINUE
 106 :             NC=IPCOM(/2)
 107 :             DO 320 IC=1,NC
 108 :                IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 320
 109 :                IF(IPHAR(IC).EQ.NOHARM(IB))  GO TO 331
 110 :  320        CONTINUE
 111 :             IPCOM(**)=NOCOMP(IB)
 112 :             IPHAR(**)=NOHARM(IB)
 113 :             NC=NC+1
 114 :  331        MILCO=MILCO+1
 115 :  330     CONTINUE
 116 : C     
 117 :          IF(MILCO.NE.0) THEN
 118 :             MELEME=IGEOC
 119 :             SEGACT MELEME
 120 :             NBELEM=NUM(/2)
 121 :             DO 310 IB=1,NBELEM
 122 :                K=NUM(1,IB)
 123 :                IF(ICPR(K).NE.0) GO TO 310
 124 :                IK=IK+1
 125 :                ICPR(K)=IK
 126 :  310        CONTINUE
 127 :             SEGDES MELEME
 128 :          ENDIF
 129 :          SEGDES MSOUPO
 130 :  350  CONTINUE
 131 :       SEGDES MSWMIL
 132 : C     
 133 :       NNIN=NC
 134 :       NNNOE=IK
 135 :       SEGINI MTRAV
 136 : C     
 137 : C     REMPLISSAGE DES TABLEAUX DU SEGMENT MTRAV
 138 : C     
 139 :       DO 380 IA=1,NNIN
 140 :          INCO(IA)=IPCOM(IA)
 141 :          NHAR(IA)=IPHAR(IA)
 142 :  380  CONTINUE
 143 : C     
 144 :       DO 430 IA=1,NSOUPO
 145 :          MSOUPO=IPCHP(IA)
 146 :          SEGACT MSOUPO
 147 :          MELEME=IGEOC
 148 :          SEGACT MELEME
 149 :          MPOVAL=IPOVAL
 150 :          SEGACT MPOVAL
 151 :          NBELEM=NUM(/2)
 152 : C     
 153 :          DO 420 IB=1,NOCOMP(/2)
 154 :             DO 390 IC=1,NNIN
 155 :                IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 390
 156 :                IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 400
 157 :  390        CONTINUE
 158 :             GO TO 420
 159 :  400        CONTINUE
 160 :             DO 410 ID=1,NBELEM
 161 :                KI=ICPR(NUM(1,ID))
 162 :                IF(KI.EQ.0) GO TO 410
 163 :                IGEO(KI)=NUM(1,ID)
 164 :                IBIN(IC,KI)=1
 165 :                BB(IC,KI)=VPOCHA(ID,IB)
 166 :  410        CONTINUE
 167 :  420     CONTINUE
 168 :          SEGDES MELEME,MSOUPO,MPOVAL
 169 :  430  CONTINUE
 170 : C     
 171 :       ITRAV=MTRAV
 172 :       SEGDES MTRAV
 173 : C     
 173 :       CALL CRECHP(ITRAV,IPOIN2)
 174 : C      ATTRIBUTION D'UNE NATURE A IPOIN2 IDENTIQUE AU CHPO IPOIN1
 175 :       MCHPO1 = IPOIN2
 176 :       SEGACT MCHPO1
 177 :       NAT = MAX ( MCHPO1.JATTRI(/1) , 1)
 178 :       NSOUPO = MCHPO1.IPCHP(/1)
 179 :       SEGADJ MCHPO1
 180 :       IF ( JATTRI(/1) .GE. 1 ) THEN
 181 :          MCHPO1.JATTRI(1) = JATTRI(1)
 182 :       ELSE
 183 :          MCHPO1.JATTRI(1) = 0
 184 :       ENDIF
 185 :       SEGDES MCHPOI,MCHPO1
 186 :       SEGSUP MTRAV,MTRA,MTR1,MTR2
 187 :       RETURN
 188 :       END
 189 : 
 190 : 
 191 : 
 192 : 
 193 :  
 194 :