Télécharger proba2.eso

Retour à la liste

Numérotation des lignes :

  1. C PROBA2 SOURCE BP208322 17/04/21 21:15:06 9404
  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. CHARACTER*8 TYPRET
  11. -INC SMCOORD
  12. -INC CCOPTIO
  13. -INC SMTABLE
  14. -INC SMRIGID
  15. -INC SMELEME
  16. PARAMETER(ZERO=0.D0)
  17.  
  18. segment icta
  19. integer icpt(ima),icre(ima)
  20. character*4 iccomp(ima)
  21. endsegment
  22.  
  23. iriout = 0
  24. mtable = itmod
  25. segact mtable
  26. im1 = mlotab - 1
  27. ima = im1
  28. * pointe les entrees de la table
  29. segini icta
  30. do im = 1,im1
  31. TYPRET = ' '
  32. ITAB2 = 0
  33. CALL ACCTAB(ITMOD,'ENTIER',IM,X0,' ',.true.,IP0,
  34. & TYPRET,I1,X1,' ',.true.,ITAB2)
  35. IF(TYPRET.NE.'TABLE ' .OR.ITAB2.LE.0) THEN
  36. ima = im - 1
  37. GOTO 1
  38. ENDIF
  39. CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_LIAISON',.true.,IP0,
  40. & 'POINT',I1,X1,' ',.true.,IPL1)
  41. CALL ACCTAB(ITAB2,'MOT',I0,X0,'DDL_LIAISON',.true.,IP0,
  42. & 'MOT',I1,X1,motddl,.true.,I1)
  43. CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_REPERE',.true.,IP0,
  44. & 'POINT',I1,X1,' ',.true.,IPTS)
  45. IF(IERR.NE.0) RETURN
  46. icpt(im) = ipl1
  47. iccomp(im) = motddl
  48. icre(im) = ipts
  49. enddo
  50. 1 CONTINUE
  51. *
  52. nbnn = 3
  53. nbsous = 0
  54. nbref = 0
  55. nbelem = ima
  56. segini meleme
  57. itypel = 22
  58. kele = 0
  59. do im = 1, ima
  60. if (icpt(im).eq.0) goto 99
  61. iplc = icpt(im)
  62. motddl= iccomp(im)
  63. do jn = im+1,ima
  64. if (icpt(jn).eq.0) goto 89
  65. if (icpt(jn).ne.iplc) goto 89
  66. if (iccomp(jn).ne.motddl) goto 89
  67. *
  68. CALL CREPO1 (ZERO, ZERO, ZERO, IPTS)
  69. kele = kele + 1
  70. num(1,kele) = ipts
  71. num(2,kele) = icre(im)
  72. num(3,kele) = icre(jn)
  73.  
  74. icpt(jn) = 0
  75. 89 continue
  76. enddo
  77.  
  78. 99 continue
  79. enddo
  80.  
  81. if (kele.eq.0) then
  82. segsup meleme
  83. goto 101
  84. endif
  85.  
  86. nbelem = kele
  87. segadj meleme
  88. *
  89.  
  90. nrigel = 1
  91. nrige = 6
  92. segini mrigid
  93. nligrp = 3
  94. nligrd = 3
  95. segini descr
  96. lisinc(1) = 'LX'
  97. lisdua(1) = 'FLX'
  98. noelep(1) = 1
  99. noeled(1) = 1
  100. do ig = 2,3
  101. lisinc(ig) = 'BETA'
  102. lisdua(ig) = 'FBET'
  103. noelep(ig) = ig
  104. noeled(ig) = ig
  105. enddo
  106.  
  107. nelrig = nbelem
  108. * segini imatri
  109. segini xmatri
  110. * do i = 1,nelrig
  111. * imattt(i) = xmatri
  112. * enddo
  113. do iel=1,nbelem
  114. re(1,1,iel) = 0.D0
  115. re(1,2,iel) = 1.d0
  116. re(1,3,iel) = -1.d0
  117. re(2,1,iel) = 1.d0
  118. re(2,2,iel) = 0.D0
  119. re(2,3,iel) = 0.D0
  120. re(3,1,iel) = -1.d0
  121. re(3,2,iel) = 0.D0
  122. re(3,3,iel) = 0.D0
  123. enddo
  124. IRIGEL(1,1) = meleme
  125. IRIGEL(3,1) = DESCR
  126. IRIGEL(4,1) = xmatri
  127. IRIGEL(2,1) = 0
  128. IRIGEL(5,1) = NIFOUR
  129. IRIGEL(6,1) = 0
  130. coerig(1) = 1.d0
  131.  
  132. iriout = mrigid
  133. segdes meleme, mrigid , descr, xmatri
  134. if (iriout.eq.0) call erreur(-5)
  135. 101 segsup icta
  136. return
  137. end
  138.  
  139.  
  140.  
  141.  
  142.  
  143.  
  144.  

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