Esope source files

   1 : C IMPOS4    SOURCE    CHAT      09/10/09    21:19:01     6519           
   2 :       SUBROUTINE IMPOS4
   3 : c
   4 : c     sous routine pour l'opérateur IMPO option CONT
   5 : c     qui donne le contour des contacts à partir de la rigidite
   6 : c     active calculée par impos4.eso
   7 : c
   8 : c   
   9 : c
  10 : c  entree:
  11 : c      IPRIG pointeur sur l
  12 : c  sortie:
  13 : c  MAIL2 = contour des surfaces en contact formé d'elements SEG2
  14 : c
  15 : c
  16 :       IMPLICIT INTEGER(I-N)
  17 :       IMPLICIT REAL*8 (A-H,O-Z)
  18 :       LOGICAL FLAG1
  19 : -INC CCOPTIO
  20 : -INC SMCOORD
  21 : -INC SMELEME     
  22 : -INC SMRIGID  
  23 : -INC SMCHPOI   
  24 :       SEGMENT MCTC
  25 : c      mctc contient les surface en vis a vis
  26 :         INTEGER IPOT1(NNO1)
  27 :         INTEGER IPOT2(NNO2)
  28 :       ENDSEGMENT
  29 :       POINTEUR MCTC1.MCTC,MCTC2.MCTC
  30 : c
  31 :       SEGMENT LCTC
  32 : c       imctc pointe vers les mctc
  33 :         INTEGER IMCTC(NBELEM,2)
  34 :       ENDSEGMENT
  35 : c
  36 :       SEGMENT MPLX
  37 : c        contient les numero de points qui supportent un composante
  38 : c        'lx'  
  39 :           INTEGER IPLX(NPLX)
  40 :       ENDSEGMENT     
  41 : c
  42 : c executable:
  43 :       IF ( IDIM .NE. 2 ) THEN
  44 :           INTERR(1) = IDIM
  45 :           RETURN
  46 :       ENDIF
  47 : c
  47 :       CALL LIROBJ ('MAILLAGE',MELEME,1,IRETOU)                                  
  48 :       IF (IERR.NE.0) RETURN                                                      
  48 :       CALL LIROBJ ('CHPOINT ',MCHPOI,1,IRETOU)                                  
  49 :       IF (IERR.NE.0) RETURN      
  50 : c
  51 :       SEGACT MCHPOI
  52 :       NPLX = 0
  53 :       SEGINI MPLX
  54 : c       boucle sur les msoupo pour remplir mplx de tous les points 
  55 : c       supportant une composante nommée 'lx'
  56 :       DO 300 I=1,IPCHP(/1)
  57 :          MSOUPO = IPCHP(I)
  58 :          SEGACT MSOUPO
  59 : c        boucle sur les noms de composantes
  60 :          DO 200 J=1,NOCOMP(/1)
  61 :            IF ( NOCOMP(J) .EQ. 'LX' ) THEN
  62 :              IPT1 = IGEOC 
  63 :              SEGACT IPT1 
  64 :              NNPLX = NPLX
  65 : *             print *, 'nplx=',nplx
  66 :              NPLX = NPLX + IPT1.NUM(/2)
  67 :              SEGADJ MPLX
  68 : c            on remplit mplx
  69 :              DO 100 K = 1,IPT1.NUM(/2)
  70 : *               print *,'noeud actif',IPT1.NUM(1,K)
  71 :                IPLX(NNPLX+K)=IPT1.NUM(1,K)
  72 :  100         CONTINUE
  73 :              SEGDES IPT1
  74 :           ENDIF
  75 :  200    CONTINUE
  76 :         SEGDES MSOUPO
  77 :  300  CONTINUE
  78 :       SEGDES MCHPOI
  79 : *
  80 : *      PRINT *,'nplx=',nplx
  81 : *
  82 : c
  83 :       SEGACT MELEME
  84 : c     on attend un maillage d'elements type 22 a 4 noeuds
  85 :       IF (ITYPEL .NE. 22 .OR. NUM(/1) .NE. 4) THEN
  85 :         CALL ERREUR(26)
  86 :       ENDIF
  87 : c
  88 :       NBELEM = NUM(/2)
  89 :       NB = NBELEM
  90 : *
  91 : *      PRINT *,'NBELEM=',nbelem
  92 : *
  93 : *       remplissage du segment lctc
  94 : *
  95 :       SEGINI LCTC
  96 :       DO 600 I=1,NBELEM
  97 : c       l'element est il actif
  98 :         I1 = NUM(1,I)
  99 : *        print *,'noeud lx ',i1
 100 :         FLAG1 = .FALSE.
 101 :         DO 400 J=1,NPLX
 102 :           IF (IPLX(J) .EQ. I1 ) FLAG1 = .TRUE.
 103 :  400    CONTINUE
 104 : c
 105 :         IF  (FLAG1) THEN
 106 : *
 107 : *      PRINT *,'element actif'
 108 : *        
 109 : c      l'element est actif on cree un mctc elementaire de trois points
 110 :           NNO1 = 2
 111 :           NNO2 = 1
 112 :           SEGINI MCTC
 113 :           IM2 = MCTC 
 114 :           IPOT1(1) = NUM(2,I)
 115 :           IPOT1(2) = NUM(3,I)
 116 :           IPOT2(1) = NUM(4,I)
 117 : c
 118 :          DO 500 J=1,I-1
 119 : c          on test  si le mctc a un point commun avec
 120 : c          ceux deja mis
 121 :              IM1 = IMCTC(J,1)
 122 :              IF ( IMCTC(J,2) .NE. 0) THEN
 123 : *             points communs ?
 123 :                CALL IMPOS5(IM1,IM2,IRET)
 124 :                IF (IRET .NE. 0) THEN
 125 : *                  assemblage des deux mctc
 126 : c                  im2 est remplace par le mctc resulatant de
 127 : c                  l'assemblage
 127 :                    CALL IMPOS6(IM1,IM2,IRET)
 128 : c                  invalidation du mctc im1
 129 :                    IMCTC(J,2)=0
 130 :                ENDIF
 131 :              ENDIF
 132 :  500     CONTINUE
 133 :          IMCTC(I,1)=IM2
 134 :          IMCTC(I,2)=1
 135 : c
 136 :         ENDIF
 137 :  600   CONTINUE
 138 :        SEGDES MELEME
 139 : c
 140 : c   creation du maillage correspondant formé de seg2
 141 : c
 142 : c
 143 :         NBELEM = 0
 144 :         DO 700 I=1,NB
 145 :            IF (IMCTC(I,2) .EQ. 1) THEN
 146 :                 MCTC = IMCTC(I,1)
 147 :                 NBELEM = NBELEM + IPOT1(/1) + IPOT2(/1)
 148 :            ENDIF
 149 :  700    CONTINUE 
 150 :         NBREF = 0
 151 :         NBNN = 2
 152 :         NBSOUS = 0
 153 :         SEGINI MELEME
 154 :         MAIL1 = MELEME
 155 :         ITYPEL = 2
 156 : c
 157 :         INDI1 = 0
 158 :         DO 1000 I=1,NB
 159 :            MCTC = IMCTC(I,1)
 160 :            IF (IMCTC(I,2) .EQ. 1) THEN
 161 : c          ligne inferieure
 162 :               DO 800 J = 1,(IPOT1(/1)-1)
 163 :                 INDI1 = INDI1 + 1
 164 :                 NUM(1,INDI1)=IPOT1(J+1)
 165 :                 NUM(2,INDI1)=IPOT1(J)
 166 :  800          CONTINUE
 167 : c          premiere interconnection
 168 :               INDI1 = INDI1 + 1
 169 :               NNN = IPOT1(/1)
 170 :               NUM(1,INDI1 )=IPOT2(1)
 171 :               NUM(2,INDI1 )=IPOT1(NNN)
 172 :               
 173 : c          ligne superieure
 174 :               DO 900 J = 1,(IPOT2(/1)-1)
 175 :                 INDI1 = INDI1 + 1
 176 :                 NUM(1,INDI1)=IPOT2(J+1)
 177 :                 NUM(2,INDI1)=IPOT2(J)
 178 :  900          CONTINUE 
 179 : c          deuxieme interconnection
 180 :               INDI1 = INDI1 + 1
 181 :               NNN = IPOT2(/1)
 182 :               NUM(1,INDI1)=IPOT1(1)
 183 :               NUM(2,INDI1)=IPOT2(NNN)
 184 :            ENDIF 
 185 :            SEGSUP MCTC  
 186 :  1000   CONTINUE
 187 : c       desactivation des meleme
 188 :         SEGSUP LCTC,MPLX
 189 :         MELEME = MAIL1
 190 :         SEGDES MELEME
 190 :         CALL ECROBJ('MAILLAGE',MELEME)
 191 :         RETURN
 192 :         END 
 193 :  
 194 :  
 195 :  
 196 :  
 197 :  
 198 :  
 199 :