Esope source files

   1 : C PROBA2    SOURCE    CHAT      09/10/09    21:21:53     6519           
   2 :       SUBROUTINE PROBA2(itmod,IRIOUT)
   3 : **************
   4 : * cree une liaison entre 2 points de liaison correspondant
   5 : * au même ddl initial
   6 : **************
   7 :       IMPLICIT REAL*8(a-h,o-z)
   8 :       IMPLICIT INTEGER(I-N)
   9 :       CHARACTER*4 motinc,motddl
  10 : -INC SMCOORD
  11 : -INC CCOPTIO
  12 : -INC SMTABLE
  13 : -INC SMRIGID
  14 : -INC SMELEME
  15 : 
  16 :       segment icta
  17 :         integer icpt(ima),icre(ima)
  18 :         character*4 iccomp(ima)
  19 :       endsegment
  20 : 
  21 :       iriout = 0
  22 :       mtable = itmod
  23 :       segact mtable
  24 :       im1 = mlotab
  25 :       ima = mlotab - 1
  26 : * pointe les entrees de la table
  27 :       segini icta     
  28 :       do im = 1,ima
  28 :          CALL ACCTAB(ITMOD,'ENTIER',IM,X0,' ',.true.,IP0,
  29 :      &                      'TABLE',I1,X1,' ',.true.,ITAB2)
  29 :          CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_LIAISON',.true.,IP0,
  30 :      &                      'POINT',I1,X1,' ',.true.,IPL1)
  30 :          CALL ACCTAB(ITAB2,'MOT',I0,X0,'DDL_LIAISON',.true.,IP0,
  31 :      &                      'MOT',I1,X1,motddl,.true.,I1)
  31 :          CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_REPERE',.true.,IP0,
  32 :      &                      'POINT',I1,X1,' ',.true.,IPTS)
  33 :          icpt(im) = ipl1
  34 :          iccomp(im) = motddl
  35 :          icre(im) = ipts
  36 :       enddo
  37 : *
  38 :         nbnn = 3
  39 :         nbsous = 0
  40 :         nbref = 0
  41 :         nbelem = ima
  42 :         segini meleme
  43 :         itypel = 22
  44 :         kele = 0
  45 :       do im = 1, ima
  46 :          if (icpt(im).eq.0) goto 99
  47 :            iplc = icpt(im)
  48 :            motddl= iccomp(im) 
  49 :          do jn = im+1,ima
  50 :            if (icpt(jn).eq.0) goto 89
  51 :            if (icpt(jn).ne.iplc) goto 89
  52 :            if (iccomp(jn).ne.motddl) goto 89
  53 : *
  53 :            CALL CREPO1 (ZERO, ZERO, ZERO, IPTS)
  54 :            kele = kele + 1
  55 :            num(1,kele) = ipts
  56 :            num(2,kele) = icre(im)
  57 :            num(3,kele) = icre(jn)
  58 : 
  59 :            icpt(jn) = 0
  60 :  89       continue  
  61 :          enddo
  62 : 
  63 :  99      continue
  64 :       enddo      
  65 : 
  66 :       if (kele.eq.0) then
  67 :        segsup meleme
  68 :        goto 101
  69 :       endif
  70 : 
  71 :       nbelem = kele 
  72 :       segadj meleme
  73 : *
  74 :       
  75 :       nrigel = 1
  76 :       nrige = 6
  77 :       segini mrigid
  78 :       nligrp = 3
  79 :       nligrd = 3
  80 :       segini descr
  81 :         lisinc(1) = 'LX'
  82 :         lisdua(1) = 'FLX'
  83 :         noelep(1) = 1
  84 :         noeled(1) = 1
  85 :         do ig = 2,3
  86 :          lisinc(ig) = 'BETA' 
  87 :          lisdua(ig) = 'FBET' 
  88 :          noelep(ig) = ig
  89 :          noeled(ig) = ig
  90 :         enddo
  91 : 
  92 :       nelrig = nbelem
  93 : *      segini imatri
  94 :       segini xmatri
  95 : *      do i = 1,nelrig
  96 : *       imattt(i) = xmatri
  97 : *      enddo
  98 :       do iel=1,nbelem
  99 :       re(1,1,iel) = 0.
 100 :       re(1,2,iel) = 1.d0
 101 :       re(1,3,iel) = -1.d0
 102 :       re(2,1,iel) = 1.d0
 103 :       re(2,2,iel) = 0.
 104 :       re(2,3,iel) = 0.
 105 :       re(3,1,iel) = -1.d0
 106 :       re(3,2,iel) = 0.
 107 :       re(3,3,iel) = 0.
 108 :       enddo
 109 :            IRIGEL(1,1) = meleme
 110 :            IRIGEL(3,1) = DESCR
 111 :            IRIGEL(4,1) = xmatri
 112 :            IRIGEL(2,1) = 0
 113 :            IRIGEL(5,1) = NIFOUR
 114 :            IRIGEL(6,1) = 0
 115 :            coerig(1) = 1.d0
 116 : 
 117 :       iriout = mrigid
 118 :       segdes meleme, mrigid , descr,  xmatri
 118 :        if (iriout.eq.0) call erreur(-5)
 119 :  101  segsup icta
 120 :       return
 121 :       end 
 122 :  
 123 :