Esope source files

   1 : C VERSEN    SOURCE    CHAT      07/10/29    21:30:14     5940           
   2 : C   CE SOUS PROGRAMME TRES ATTENDU VERIFIE QUE DANS UN MAILLAGE
   3 : C   1 DEUX ELEMENTS AU PLUS ONT UNE ARETE COMMUNE
   4 : C   2 CETTE ARETE EST ORIENTE DE MANIERE OPPOSEE DANS CHACUN DES 2
   5 : C
   6 : C     CECI EXISTAIT DEJA DANS COCO (REALISATION THIERRY CHARRAS)
   7 : C   LA PRESENTE PROGRAMMATION EST HONTEUSEMENT INSPIREE DE CELLE
   8 : C   DE PRCONT
   9 : C
  10 : C   COPYRIGHT P VERPEAUX & CEA/IRDI/DEDR/DEMT/SMTS/LAMS
  11 : C
  12 :       SUBROUTINE VERSEN
  13 :       IMPLICIT INTEGER(I-N)
  14 : -INC CCOPTIO
  15 : -INC CCGEOME
  16 : -INC SMELEME
  17 : -INC SMCOORD
  18 :       SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  19 :       SEGMENT KON(NBCON,NMAX,2)
  19 :       CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  20 :       IF (IERR.NE.0) RETURN
  21 :       SEGINI ICPR
  22 :       DO 1 I=1,ICPR(/1)
  23 :    1  ICPR(I)=0
  24 :       ITE=0
  25 :       SEGACT MELEME
  26 :       IPT1=MELEME
  27 :       DO 3 I=1,MAX(1,LISOUS(/1))
  28 :       IF (LISOUS(/1).NE.0) THEN
  29 :        IPT1=LISOUS(I)
  30 :        SEGACT IPT1
  31 :       ENDIF
  32 :       K=IPT1.ITYPEL
  33 :       IDEP=NSPOS(K)
  34 :       IF (NBSOM(K).GT.0) THEN
  35 :         IFEP=IDEP+NBSOM(K)-1
  36 :       ELSE
  37 : C       Cas du polygone
  38 :         IFEP=IDEP+NUM(/1)-1
  39 :       ENDIF
  40 :       IF (IFEP.LT.IDEP) GOTO 8
  41 :       DO 4 JJ=IDEP,IFEP
  42 :         J=IBSOM(JJ)
  43 :         DO 4 K=1,IPT1.NUM(/2)
  44 :           IPOIT=IPT1.NUM(J,K)
  45 :           IF (ICPR(IPOIT).NE.0) GOTO 7
  46 :           ITE=ITE+1
  47 :           ICPR(IPOIT)=ITE
  48 :    7      CONTINUE
  49 :    4  CONTINUE
  50 :    8  CONTINUE
  51 :    3  CONTINUE
  52 :       IF (ITE.NE.0) GOTO 6
  53 :       SEGSUP ICPR
  53 :       CALL ERREUR(16)
  54 :       RETURN
  55 :    6  CONTINUE
  56 : C   ITE EST LE NOMBRE DE POINTS A CONSIDERER  ICPR LE TABLEAU
  57 : C   ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS
  58 :       NBCON=7
  59 :       NBCONR=NBCON-1
  60 :       NMAX=(10*ITE)/NBCON+10
  61 :       SEGINI KON
  62 : C   FABRICATION DU TABLEAU DES CONNECTIONS
  63 : C    1  POINT FINAL
  64 : C    2  POINT INTERMEDIAIRE EVENTUEL ET SENS
  65 :       ICHAIN=ITE
  66 :       DO 30 IO=1,MAX(1,LISOUS(/1))
  67 :       IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  68 :       K=IPT1.ITYPEL
  69 :       KTYPEL=K
  70 : C  LE NOMBRE DE FACE EST 1 QUEL EST SON TYPE
  71 :       KK=LTEL(2,K)
  72 : *  POUR LE CAS DES LIGNE ON PREND LES FACES TRIANGLE  CORRESPONDANTES
  73 :       IF (K.EQ.KDEGRE(K)) THEN
  74 :         KA=2*K
  75 :         KK=LTEL(2,KA)
  76 :       ENDIF
  77 :         IF (KK.EQ.0) GOTO 21
  78 :       ITYP=LDEL(1,KK)
  79 :       IDEP=LDEL(2,KK)
  80 :       IF (ITYP.NE.6) THEN
  81 :         IFEP=IDEP+KDFAC(1,ITYP)-1
  82 :       ELSE
  83 : C       Cas du polygone
  84 :         IFEP= IDEP+IPT1.NUM(/1)-1
  85 :       ENDIF
  86 :       NBNN=KDEGRE(K)
  87 :       IPAS=NBNN-1
  88 :       IF (K.EQ.KDEGRE(K)) IFEP=IDEP
  89 :       DO 22 I=1,IPT1.NUM(/2)
  90 :       DO 22 J=IDEP,IFEP,IPAS
  91 :       NMIL=1
  92 :       N1=ICPR(IPT1.NUM(LFAC(J),I))
  93 :       JSUIV=J+IPAS
  94 :       IF (JSUIV.GT.IFEP.AND.(KTYPEL.NE.KDEGRE(KTYPEL))) THEN
  95 :         JSUIV=IDEP
  96 :       ENDIF
  97 :       N2=ICPR(IPT1.NUM(LFAC(JSUIV),I))
  98 :       IF (IPAS.EQ.2) NMIL=IPT1.NUM(LFAC(J+1),I)
  99 :       NI=N1
 100 :       NJ=N2
 101 :       IF (N1*N2.EQ.0) GOTO 32
 102 :       KSCOL=IPT1.ICOLOR(I)
 103 :       IPO=0
 104 :   23  CONTINUE
 105 :   24  DO 25 K=1,NBCONR
 106 :       IF (KON(K,NI,1).EQ.0) GOTO 26
 107 :       IF (KON(K,NI,1).EQ.NJ) GOTO 27
 108 :   25  CONTINUE
 109 :       IF (KON(NBCON,NI,1).EQ.0) GOTO 28
 110 :       NI=KON(NBCON,NI,1)
 111 :       GOTO 24
 112 :   27  CONTINUE
 113 :       IF(IIMPI.EQ.123)WRITE(IOIMP,1122) KON(K,NI,2),NMIL
 113 :       IF (KON(K,NI,2).EQ.0) CALL ERREUR(319)
 113 :       IF (1.*KON(K,NI,2)*NMIL.GT.0.) CALL ERREUR(318)
 114 : *     IF (IERR.NE.0) GOTO 32
 115 :       KON(K,NI,2)=0
 116 :       GOTO 29
 117 :   26  KON(K,NI,1)=NJ
 118 :       KON(K,NI,2)=NMIL
 119 :       GOTO 29
 120 :   28  ICHAIN=ICHAIN+1
 121 :       IF (ICHAIN.GE.NMAX) THEN
 122 :          NMAX=NMAX+250
 123 :          SEGADJ KON
 124 :       ENDIF
 125 :       KON(NBCON,NI,1)=ICHAIN
 126 :       K=1
 127 :       NI=ICHAIN
 128 :       GOTO 26
 129 :   29  IF (IPO.EQ.1) GOTO 22
 130 :       NMIL=-NMIL
 131 :       NI=N2
 132 :       NJ=N1
 133 :       IPO=1
 134 :       GOTO 23
 135 :   22  CONTINUE
 136 :   21  CONTINUE
 137 :       IF (LISOUS(/1).NE.0) SEGDES IPT1
 138 :   30  CONTINUE
 139 :       GOTO 31
 139 :   32  CALL ERREUR(26)
 140 :       SEGSUP KON,ICPR
 141 :       SEGDES MELEME
 142 :       RETURN
 143 :   31  CONTINUE
 144 :       SEGDES MELEME
 145 :       IF (IIMPI.EQ.2)WRITE (IOIMP,1122) (((KON(I,J,K),K=1,2),I=1,NBCON),
 146 :      # J=1,NMAX)
 147 :  1122 FORMAT(1X,14I5)
 148 : *  TEST QUE LES ARETES RESTANTES TOURNENT DANS LE MEME SENS
 149 :       DO 100 I=1,ITE
 150 :       IF(IIMPI.EQ.123)WRITE(IOIMP,1122) KON(1,I,2),KON(2,I,2)
 150 :       IF (1.*KON(1,I,2)*KON(2,I,2).GT.0.) CALL ERREUR(318)
 151 :  100  CONTINUE
 151 :       CALL REFUS
 152 :       SEGSUP ICPR,KON
 153 :       END
 154 :  
 155 :  
 156 :  
 157 :