Télécharger bloqu2.eso

Retour à la liste

Numérotation des lignes :

  1. C BLOQU2 SOURCE BP208322 17/09/15 21:15:01 9548
  2. SUBROUTINE BLOQU2(IPT)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. -INC SMTABLE
  6. -INC CCOPTIO
  7. cbp ON SUPPOSE QUE LA TABLE EST BIEN DECRITE
  8. cbp ET ON COMMENTE TOUS LES TEST INUTILES
  9. cbp segment lispoi
  10. cbp INTEGER pilpoi(mpoin),pilmul(mpoin)
  11. cbp endsegment
  12.  
  13. cbp CHARACTER*4 MOTPV(3)
  14. CHARACTER*4 charre
  15. CHARACTER*8 TYPRET
  16. cbp c on autorise les ddl mecanique + thermique + liquide
  17. cbp PARAMETER (NPRIN=15)
  18. cbp CHARACTER*4 MOPRIN(NPRIN)
  19. cbp DATA MOPRIN / 'UX ','UY ','UZ ','UR ','UT ',
  20. cbp & 'RX ','RY ','RZ ','RT ','P ','PI ',
  21. cbp & 'T ','RR ','TINF','TSUP'/
  22. cbp DATA MODUAL / 'FX ','FY ','FZ ','FR ','FT ',
  23. cbp & 'MX ','MY ','MZ ','MT ','FP ','FPI ',
  24. cbp & 'Q ','MR ','QINF','QSUP'/
  25.  
  26. krig = 0
  27. IPO = 0
  28. mtable = ipt
  29. segact mtable
  30. ima = mlotab - 1
  31. IF (ima.eq.0) RETURN
  32. cbp DO kmo = 1,NPRIN
  33. cbp mpoin = 50
  34. cbp kpoin = 0
  35. cbp segini lispoi
  36. cbp DO im = 1,ima
  37. DO 10 im = 1,ima
  38. TYPRET=' '
  39. CALL ACCTAB(IPT,'ENTIER',IM,0.d0,' ',.true.,IP0,
  40. & TYPRET,I1,X1,CHARRE,.true.,ITMOD)
  41. IF(TYPRET.ne.'TABLE') GOTO 10
  42. IF (IERR.NE.0) RETURN
  43. CALL ACCTAB(ITMOD,'MOT',I0,X0,'DDL_LIAISON',.true.,IP0,
  44. & 'MOT',I1,X1,charre,.true.,IPTS)
  45. IF (IERR.NE.0) RETURN
  46. cbp IF (charre.eq.moprin(kmo)) THEN
  47. CALL ACCTAB(ITMOD,'MOT',I0,X0,'POINT_LIAISON',.true.,IP0,
  48. & 'POINT',I1,X1,charre,.true.,IPTS)
  49. IF (IERR.NE.0) RETURN
  50. c
  51. c
  52. cbp do ik = 1,kpoin
  53. cbp if (ipts.eq.pilpoi(ik)) then
  54. cbp c write(6,*)'combinaison point -ddl déjà traitée', ipts,charre
  55. cbp goto 10
  56. cbp endif
  57. cbp enddo
  58. cbp kpoin = kpoin + 1
  59.  
  60. cbp if (kpoin.gt.mpoin) then
  61. cbp mpoin = mpoin + 50
  62. cbp segadj lispoi
  63. cbp endif
  64. cbp pilpoi(kpoin) = IPTS
  65.  
  66. CALL ECRCHA(charre)
  67. CALL ECROBJ('POINT',IPTS)
  68. CALL BLOQUE
  69. CALL LIROBJ('RIGIDITE',ir1, 1,iretou)
  70. IF(IERR.NE.0) RETURN
  71. CALL ECCTAB(ITMOD,'MOT',0,0.0D0,'BLOCAGE',.TRUE.,IPO,
  72. & 'RIGIDITE',0,0.0D0,' ',.TRUE.,ir1)
  73. krig = krig + 1
  74. if (krig.eq.1) then
  75. ir2 = ir1
  76. else
  77. cbp call fusrig(ir1,ir2,irt)
  78. call fusrig(ir2,ir1,irt)
  79. if (ierr.ne.0) return
  80. ir2 = irt
  81. endif
  82.  
  83. cbp ENDIF
  84. 10 CONTINUE
  85. cbp ENDDO
  86. cbp if (kpoin.eq.0) goto 1130
  87. c
  88. c 1130 segsup lispoi
  89. cbp ENDDO
  90.  
  91.  
  92. CALL ECROBJ('RIGIDITE',ir2)
  93.  
  94. RETURN
  95.  
  96. END
  97.  
  98.  
  99.  
  100.  
  101.  

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