Télécharger credef.eso

Retour à la liste

Numérotation des lignes :

  1. C CREDEF SOURCE PV 17/02/03 21:15:01 9298
  2. C CE SOUS-PROGRAMME CREE LES CHAMPS DE COORDONNEES ASSOCIES AUX
  3. C DEFORMES. IL ACTUALISE LES ELEMENTS SUR CES CHAMPS
  4. C
  5. SUBROUTINE CREDEF(KABEL,KABCOR,KABCPR,MDEFOR,LABCO2,sdef )
  6. IMPLICIT INTEGER(I-N)
  7. -INC CCOPTIO
  8. -INC CCREEL
  9. -INC SMELEME
  10. -INC SMCOORD
  11. -INC SMCHPOI
  12. -INC SMDEFOR
  13. -INC SMVECTE
  14. SEGMENT KABEL(NDEF)
  15. SEGMENT KABCOR(NDEF)
  16. SEGMENT KABCPR(NDEF)
  17. SEGMENT LABCO2(3,NDEF)
  18. SEGMENT XCO(IDIM,NCO)
  19. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  20. SEGMENT SDEF
  21. REAL AMPIMP(NDEF)
  22. ENDSEGMENT
  23. CHARACTER*4 NODEF(3),NODEG(3)
  24. DATA NODEF /'UX ','UY ','UZ '/
  25. DATA NODEG /'UR ','UZ ','UT '/
  26. C
  27. C
  28. LABCO2=0
  29. SEGACT MCOORD
  30. SEGACT MDEFOR
  31. C
  32. C
  33. NDEF=AMPL(/1)
  34. SEGINI KABEL,KABCOR,KABCPR,LABCO2
  35. DO 200 IDEF=1,NDEF
  36. LABCO2(3,IDEF)=MTVECT(IDEF)
  37. SEGINI ICPR
  38. KABCPR(IDEF)=ICPR
  39. DO 10 I=1,XCOOR(/1)/(IDIM+1)
  40. ICPR(I)=0
  41. 10 CONTINUE
  42. NCO=0
  43. MELEME=IELDEF(IDEF)
  44. KABEL(IDEF)=MELEME
  45. SEGACT MELEME
  46. NBSOUS=LISOUS(/1)
  47. IPT1=MELEME
  48. DO 20 ISOUS=1,MAX(1,NBSOUS)
  49. IF (NBSOUS.NE.0) THEN
  50. IPT1=LISOUS(ISOUS)
  51. SEGACT IPT1
  52. ENDIF
  53. DO 22 I=1,IPT1.NUM(/1)
  54. DO 22 J=1,IPT1.NUM(/2)
  55. IP=IPT1.NUM(I,J)
  56. IF (ICPR(IP).NE.0) GOTO 22
  57. NCO=NCO+1
  58. ICPR(IP)=NCO
  59. 22 CONTINUE
  60. 20 CONTINUE
  61. C MAINTENANT CREER LES COORDONNEES DEFORMES
  62. SEGINI XCO
  63. DO 40 J=1,XCOOR(/1)/(IDIM+1)
  64. IPC=ICPR(J)
  65. IF (IPC.EQ.0) GOTO 40
  66. IREF=(IDIM+1)*(J-1)
  67. DO 41 I=1,IDIM
  68. XCO(I,IPC)=XCOOR(IREF+I)
  69. 41 CONTINUE
  70. 40 CONTINUE
  71. KABCOR(IDEF)=XCO
  72. MCHPOI=ICHDEF(IDEF)
  73. IF (AMPIMP(IDEF).LT.REAL(XSGRAN)/2.D0) THEN
  74. AMP=AMPIMP(IDEF)
  75. ELSE
  76. AMP=AMPL(IDEF)
  77. ENDIF
  78. SEGACT MCHPOI
  79. NSOUPO=IPCHP(/1)
  80. DO 60 ISOUP=1,NSOUPO
  81. MSOUPO=IPCHP(ISOUP)
  82. SEGACT MSOUPO
  83. MPOVAL=IPOVAL
  84. SEGACT MPOVAL
  85. IPT2=IGEOC
  86. SEGACT IPT2
  87. NC=NOCOMP(/2)
  88. DO 70 IC=1,NC
  89. DO 80 INUM=1,IDIM
  90. IF (IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  91. IF (NOCOMP(IC).EQ.NODEF(INUM)) GOTO 81
  92. ELSE
  93. IF (NOCOMP(IC).EQ.NODEG(INUM)) GOTO 81
  94. ENDIF
  95. 80 CONTINUE
  96. GOTO 70
  97. 81 CONTINUE
  98. DO 90 IEL=1,IPT2.NUM(/2)
  99. IP=ICPR(IPT2.NUM(1,IEL))
  100. IF (IP.EQ.0) GOTO 90
  101. XCO(INUM,IP)=XCO(INUM,IP)+AMP*VPOCHA(IEL,IC)
  102. 90 CONTINUE
  103. 70 CONTINUE
  104. SEGDES IPT2,MPOVAL,MSOUPO
  105. 60 CONTINUE
  106. SEGDES MCHPOI
  107. IF (LABCO2(3,IDEF).EQ.0) GOTO 200
  108. C IL FAUT ICI REGARDER LES VECTEURS QUI SONT DANS LA DEFORME
  109. MVECTE=LABCO2(3,IDEF)
  110. CALL CREVEC(MELEME,ICPR,KABCOR,LABCO2,MVECTE,IDEF)
  111. 200 CONTINUE
  112. SEGDES MDEFOR
  113. RETURN
  114. END
  115.  
  116.  
  117.  
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  

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