Télécharger credef.eso

Retour à la liste

Numérotation des lignes :

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

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