Télécharger la plaquette Cast3M


fr en

Télécharger probas.eso

Retour à la liste

Numérotation des lignes : 

probas

  1. C PROBAS    SOURCE    FANDEUR   22/03/01    21:15:06     11301          
  2.       SUBROUTINE PROBAS(IRIIN,itmod,IRIOUT)
  3.       IMPLICIT REAL*8(a-h,o-z)
  4.       IMPLICIT INTEGER(I-N)
  5.  
  6. -INC PPARAM
  7. -INC CCOPTIO
  8.  
  9. -INC SMCOORD
  10. -INC SMTABLE
  11. -INC SMRIGID
  12. -INC SMELEME
  13.       PARAMETER(ZERO=0.D0)
  14.       segment icpr(nbpts)
  15.  
  16.       CHARACTER*(LOCHPO) motinc,motddl
  17.       CHARACTER*8 TYPRET,TYPMOT,TYPENT
  18.       CHARACTER*(32) motbid
  19.       LOGICAL bool
  20.  
  21.       bool = .TRUE.
  22.       I0 = 0
  23.       I1 = 0
  24.       X0 = ZERO
  25.       X1 = ZERO
  26.       TYPMOT = 'MOT     '
  27.       TYPENT = 'ENTIER  '
  28.       motbid = ' '
  29.       IP0 = 0
  30.       IP1 = 0
  31.  
  32.       MRIGID = IRIIN
  33.       mtable = itmod
  34.       segact mtable
  35.       im1 = mlotab - 1
  36.       ima = im1
  37. * pour chaque noeud implique dans une liaison on fait intervenir toutes
  38. * les solutions statiques associées
  39. * on les recense donc
  40.       segini icpr
  41.       do im = 1,im1
  42.          TYPRET = ' '
  43.          ITAB2  = 0
  44.          CALL ACCTAB(ITMOD,TYPENT,IM,X0,motbid,bool,IP0  ,
  45.      &                     TYPRET,I1,X1,motbid,bool,ITAB2)
  46.          IF(IERR.NE.0) RETURN
  47.          IF (TYPRET.NE.'TABLE   ' .OR.ITAB2.LE.0) THEN
  48.            ima = im - 1
  49.            GOTO 1
  50.          ENDIF
  51.          TYPRET = 'POINT   '
  52.          motbid = 'POINT_LIAISON'
  53.          CALL ACCTAB(ITAB2,TYPMOT,I0,X0,motbid(1:13),bool,IP0 ,
  54.      &                     TYPRET,I1,X1,motbid      ,bool,IPL1)
  55.          IF(IERR.NE.0) RETURN
  56.          icpr(IPL1) = icpr(IPL1) + 1
  57.       enddo
  58.  1    CONTINUE
  59.  
  60.       segact mrigid
  61. c*      nrige = irigel(/1)
  62.       nrige0 = irigel(/2)
  63.  
  64.       nrigel = nrige0
  65.       segini ri1
  66.       ri1.mtymat = mtymat
  67.       ri1.iforig = iforig
  68.  
  69.       kige = 0
  70.       nrigel = kige
  71.       segini ri2
  72.       ri2.mtymat = mtymat
  73.       ri2.iforig = iforig
  74.  
  75.       krigel = 0
  76.       DO ire = 1,nrige0
  77.         meleme = irigel (1,ire)
  78.         segact meleme
  79.         if (itypel.ne.22) then
  80.            call erreur(977)
  81.            return
  82.         endif
  83.         nbelem = num(/2)
  84.         nbele0 = nbelem
  85.         descr = irigel(3,ire)
  86.         segact descr
  87.         nligrp0 = noelep(/1)
  88.         nligrd0 = noeled(/1)
  89.         nligrp = nligrp0
  90.         nligrd = nligrp
  91.         segini des1
  92.         des1.lisinc(1) = 'LX      '
  93.         des1.lisdua(1) = 'FLX     '
  94.         des1.noelep(1) = 1
  95.         des1.noeled(1) = 1
  96.         do ig =2,nligrp
  97.          des1.lisinc(ig) = 'BETA    '
  98.          des1.lisdua(ig) = 'FBET    '
  99.          des1.noelep(ig) = ig
  100.          des1.noeled(ig) = ig
  101.         enddo
  102.         segini,des2=des1
  103.  
  104.         nbnn = nligrp0
  105.         nbsous = 0
  106.         nbref = 0
  107.         segini ipt2
  108.         ipt2.itypel = itypel
  109.         nbelem = 1
  110.         segini ipt1
  111.         ipt1.itypel = itypel
  112.         ri1.coerig(ire) = coerig(ire)
  113.         kele = 0
  114.  
  115.         DO iele = 1,nbele0
  116.  
  117.           X0 = ZERO
  118. * le premier point correspond aux multiplicateurs
  119.           CALL CREPO1 (X0, X0, X0, IPTS)
  120.           ipt1.num(1,1) = ipts
  121.           koel = 1
  122.           do igrp = 2,nligrp0
  123.              jno = noelep(igrp)
  124.              motinc = lisinc(igrp)
  125.              IP1 = num(jno,iele)
  126.              do im = 1,ima
  127.               TYPRET = 'TABLE   '
  128.               motbid = ' '
  129.               CALL ACCTAB(ITMOD,TYPENT,IM,X0,motbid,bool,IP0  ,
  130.      &                          TYPRET,I1,X1,motbid,bool,ITAB2)
  131.               IF (IERR.NE.0) RETURN
  132.               TYPRET = 'POINT   '
  133.               motbid = 'POINT_LIAISON'
  134.               CALL ACCTAB(ITAB2,TYPMOT,I0,X0,motbid( 1:13),bool,IP0,
  135.      &                          TYPRET,I1,X1,motbid(14:32),bool,IPL1)
  136.               IF (IERR.NE.0) RETURN
  137.               motbid = 'DDL_LIAISON'
  138.               CALL ACCTAB(ITAB2,TYPMOT,I0,X0,motbid(1:11),bool,IP0,
  139.      &                          TYPMOT,I1,X1,motddl      ,bool,I1 )
  140.               IF (IERR.NE.0) RETURN
  141.               if (motinc.eq.motddl.and.IPL1.eq.IP1) then
  142.                 TYPRET = 'POINT   '
  143.                 motbid = 'POINT_REPERE'
  144.                 CALL ACCTAB(ITAB2,TYPMOT,I0,X0,motbid( 1:12),bool, IP0,
  145.      &                            TYPRET,I1,X1,motbid(13:32),bool,IPTS)
  146.                 IF (IERR.NE.0) RETURN
  147.             ipt1.num(igrp,1) = ipts
  148.               koel = koel + 1
  149.                goto 16
  150.               endif
  151.              enddo
  152. c point-liaison et ddl non trouvés
  153.              ipt1.num(igrp,1) = ip1
  154.              des2.lisinc(igrp) = lisinc(igrp)
  155.              des2.lisdua(igrp) = lisdua(igrp)
  156.              des2.noelep(igrp) = noelep(igrp)
  157.              des2.noeled(igrp) = noeled(igrp)
  158. *
  159.  16          continue
  160.           enddo
  161. *
  162. c creation d'un irigel
  163.           if (koel.ne.nligrp0) then
  164. c           call erreur(978)
  165. c           return
  166.            kige = kige + 1
  167.            nrigel = kige
  168.            segadj ri2
  169.            segini,ipt3=ipt1
  170.            segini,des3=des2
  171.            RI2.IRIGEL(1,kige) = IPT3
  172.            RI2.IRIGEL(3,kige) = DES3
  173.            RI2.IRIGEL(4,kige) = irigel(4,ire)
  174.            RI2.IRIGEL(2,kige) = 0
  175.            RI2.IRIGEL(5,kige) = irigel(5,ire)
  176.            RI2.IRIGEL(6,kige) = irigel(6,ire)
  177.            ri2.coerig(kige) = coerig(ire)
  178.            do ig =2,nligrp
  179.              des2.lisinc(ig) = 'BETA    '
  180.              des2.lisdua(ig) = 'FBET    '
  181.              des2.noelep(ig) = ig
  182.              des2.noeled(ig) = ig
  183.            enddo
  184.           else
  185. * toutes les inconnues sont des BETA
  186.             kele = kele + 1
  187.             do ig = 1,nligrp0
  188.              ipt2.num(ig,kele) = ipt1.num(ig,1)
  189.             enddo
  190.           endif
  191.         ENDDO
  192.  
  193.         nbelem = kele
  194.         if (nbelem.gt.0) then
  195.           segadj ipt2
  196.           krigel = krigel + 1
  197.           RI1.IRIGEL(1,krigel) = IPT2
  198.           RI1.IRIGEL(3,krigel) = DES1
  199.           RI1.IRIGEL(4,krigel) = irigel(4,ire)
  200.           RI1.IRIGEL(2,krigel) = 0
  201.           RI1.IRIGEL(5,krigel) = irigel(5,ire)
  202.           RI1.IRIGEL(6,krigel) = irigel(6,ire)
  203.           segdes des1, ipt2
  204.         else
  205.           segsup des1, ipt2
  206.         endif
  207.         segsup ipt1
  208.        ENDDO
  209.  
  210.         iriout = 0
  211.         nrigel = krigel
  212.         segadj ri1
  213. c        WRITE(6,*) 'ri1', ri1.irigel(/2), ' ri2',ri2.irigel(/2)
  214.         segdes mrigid,ri1,mtable,ri2
  215.  
  216.        if (kige.gt.0.and.krigel.gt.0) then
  217. c        WRITE(6,*) 'fus', ri1,ri2,kige,krigel
  218.          call fusrig(ri1,ri2,iriout)
  219.          segsup ri1, ri2
  220.          return
  221.        endif
  222.        if (kige.gt.0) iriout = ri2
  223.        if (krigel.gt.0) iriout = ri1
  224.        if (iriout.eq.0) call erreur(-5)
  225.        if (kige.eq.0) segsup ri2
  226.        if (krigel.eq.0) segsup ri1
  227.  
  228. c       return
  229.        END
  230.  
  231.  
  232.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales