Sources Esope | Cast3M

proba2
C PROBA2    SOURCE    BP208322  17/04/21    21:15:06     9404           
      SUBROUTINE PROBA2(itmod,IRIOUT)
**************
* cree une liaison entre 2 points de liaison correspondant
* au même ddl initial
**************
      IMPLICIT REAL*8(a-h,o-z)
      IMPLICIT INTEGER(I-N)
      CHARACTER*4 motinc,motddl
      CHARACTER*8 TYPRET
-INC SMCOORD
 
-INC PPARAM
-INC CCOPTIO
-INC SMTABLE
-INC SMRIGID
-INC SMELEME
      PARAMETER(ZERO=0.D0)
 
      segment icta
        integer icpt(ima),icre(ima)
        character*4 iccomp(ima)
      endsegment
 
      iriout = 0
      mtable = itmod
      segact mtable
      im1 = mlotab - 1
      ima = im1
* pointe les entrees de la table
      segini icta
      do im = 1,im1
         TYPRET = ' '
         ITAB2  = 0
         CALL ACCTAB(ITMOD,'ENTIER',IM,X0,' ',.true.,IP0,
     &                      TYPRET,I1,X1,' ',.true.,ITAB2)
         IF(TYPRET.NE.'TABLE   ' .OR.ITAB2.LE.0) THEN
           ima = im - 1
           GOTO 1
         ENDIF
         CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_LIAISON',.true.,IP0,
     &                      'POINT',I1,X1,' ',.true.,IPL1)
         CALL ACCTAB(ITAB2,'MOT',I0,X0,'DDL_LIAISON',.true.,IP0,
     &                      'MOT',I1,X1,motddl,.true.,I1)
         CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_REPERE',.true.,IP0,
     &                      'POINT',I1,X1,' ',.true.,IPTS)
         IF(IERR.NE.0) RETURN
         icpt(im) = ipl1
         iccomp(im) = motddl
         icre(im) = ipts
      enddo
 1    CONTINUE
*
        nbnn = 3
        nbsous = 0
        nbref = 0
        nbelem = ima
        segini meleme
        itypel = 22
        kele = 0
      do im = 1, ima
         if (icpt(im).eq.0) goto 99
           iplc = icpt(im)
           motddl= iccomp(im)
         do jn = im+1,ima
           if (icpt(jn).eq.0) goto 89
           if (icpt(jn).ne.iplc) goto 89
           if (iccomp(jn).ne.motddl) goto 89
*
           CALL CREPO1 (ZERO, ZERO, ZERO, IPTS)
           kele = kele + 1
           num(1,kele) = ipts
           num(2,kele) = icre(im)
           num(3,kele) = icre(jn)
 
           icpt(jn) = 0
 89       continue
         enddo
 
 99      continue
      enddo
 
      if (kele.eq.0) then
       segsup meleme
       goto 101
      endif
 
      nbelem = kele
      segadj meleme
*
 
      nrigel = 1
      nrige = 6
      segini mrigid
      nligrp = 3
      nligrd = 3
      segini descr
        lisinc(1) = 'LX'
        lisdua(1) = 'FLX'
        noelep(1) = 1
        noeled(1) = 1
        do ig = 2,3
         lisinc(ig) = 'BETA'
         lisdua(ig) = 'FBET'
         noelep(ig) = ig
         noeled(ig) = ig
        enddo
 
      nelrig = nbelem
*      segini imatri
      segini xmatri
*      do i = 1,nelrig
*       imattt(i) = xmatri
*      enddo
      do iel=1,nbelem
      re(1,1,iel) = 0.D0
      re(1,2,iel) = 1.d0
      re(1,3,iel) = -1.d0
      re(2,1,iel) = 1.d0
      re(2,2,iel) = 0.D0
      re(2,3,iel) = 0.D0
      re(3,1,iel) = -1.d0
      re(3,2,iel) = 0.D0
      re(3,3,iel) = 0.D0
      enddo
           IRIGEL(1,1) = meleme
           IRIGEL(3,1) = DESCR
           IRIGEL(4,1) = xmatri
           IRIGEL(2,1) = 0
           IRIGEL(5,1) = NIFOUR
           IRIGEL(6,1) = 0
           coerig(1) = 1.d0
 
      iriout = mrigid
      segdes meleme, mrigid , descr,  xmatri
       if (iriout.eq.0) call erreur(-5)
 101  segsup icta
      return
      end