Télécharger defo.eso

Retour à la liste

Numérotation des lignes :

  1. C DEFO SOURCE CB215821 19/08/20 21:16:35 10287
  2. C CONSTRUCTION D'UN OBJET DE TYPE DEFORME A PARTIR D'UNE GEOMETRIE
  3. C D'UN CHPOIN UX UY UZ ET D'UN COEF D'AMPLIFICATION
  4. C 1995 Changement de defaut de couleur P.PEGON JRC-ISPRA
  5. C
  6. SUBROUTINE DEFO
  7. IMPLICIT INTEGER(I-N)
  8. -INC CCOPTIO
  9. -INC CCGEOME
  10. -INC SMCHPOI
  11. -INC SMDEFOR
  12. -INC SMCOORD
  13. -INC SMELEME
  14. CHARACTER*4 NU(3),NV(3),NOC
  15. REAL*8 AMP,COMPMA
  16. DATA NU/'UX ','UY ','UZ '/
  17. DATA NV/'UR ','UZ ','UT '/
  18. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  19. CALL LIROBJ('CHPOINT ',MCHPOI,1,IRETOU)
  20. CALL ACTOBJ('MAILLAGE',MELEME,1)
  21. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  22. C AMPLIFICATION 1 PAR DEFAUT
  23. AMP=1.
  24. CALL LIRREE(AMP,0,IRETOA)
  25. IF (IERR.NE.0) RETURN
  26. MTVE=0
  27. CALL LIROBJ('VECTEUR ',MTVE,0,IRETOU)
  28. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  29. IF (ICOUL.EQ.0) ICOUL=IDCOUL+1
  30. ICOUL=ICOUL-1
  31. C VERIFICATION QU'IL Y A UX UY UZ PARMI LES INCONNUES DU CHPOINT
  32. SEGACT MCHPOI
  33. NSOUPO=IPCHP(/1)
  34. IRAT=1
  35. IF (NSOUPO.EQ.0) GOTO 13
  36. IRAT=1
  37. DO 10 ISOUPO=1,NSOUPO
  38. MSOUPO=IPCHP(ISOUPO)
  39. SEGACT MSOUPO
  40. NC=NOCOMP(/2)
  41. DO 11 I=1,NC
  42. NOC=NOCOMP(I)
  43. DO 12 J=1,IDIM
  44. IF (IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  45. IF (NOC.EQ.NU(J)) IRAT=0
  46. ELSE
  47. IF (NOC.EQ.NV(J)) IRAT=0
  48. ENDIF
  49. 12 CONTINUE
  50. 11 CONTINUE
  51. 10 CONTINUE
  52. IF (IRAT.EQ.1) CALL ERREUR(184)
  53. 13 CONTINUE
  54. NDEF=1
  55. SEGINI MDEFOR
  56. AMPL(1)=AMP
  57. MTVECT(1)=MTVE
  58. IELDEF(1)=MELEME
  59. ICHDEF(1)=MCHPOI
  60. JCOUL(1)=ICOUL
  61. CALL ECROBJ('DEFORME ',MDEFOR)
  62. IF (IRETOA.EQ.1) GOTO 1000
  63. * CAS DE L'AMPLIFICATION AUTOMATIQUE ON MODIFIE L'OBJET
  64. * QU'ON VIENT D'ECRIRE. C'EST PAS BIEN |
  65. * CALCUL DU CADRE
  66. XGRAND=-1E30
  67. YGRAND=-1E30
  68. ZGRAND=-1E30
  69. XPETIT= 1E30
  70. YPETIT= 1E30
  71. ZPETIT= 1E30
  72. SEGACT MELEME
  73. NBSOUS=LISOUS(/1)
  74. IPT1=MELEME
  75. DO 50 ISOUS=1,MAX0(1,NBSOUS)
  76. IF (NBSOUS.NE.0) IPT1=LISOUS(ISOUS)
  77. SEGACT IPT1
  78. DO 55 I=1,IPT1.NUM(/1)
  79. DO 55 J=1,IPT1.NUM(/2)
  80. IPT=IPT1.NUM(I,J)
  81. IREF=(IDIM+1)*(IPT-1)
  82. XPT=XCOOR(IREF+1)
  83. XGRAND=MAX(XPT,XGRAND)
  84. XPETIT=MIN(XPT,XPETIT)
  85. YPT=XCOOR(IREF+2)
  86. YGRAND=MAX(YPT,YGRAND)
  87. YPETIT=MIN(YPT,YPETIT)
  88. ZPT=XCOOR(IREF+3)
  89. ZGRAND=MAX(ZPT,ZGRAND)
  90. ZPETIT=MIN(ZPT,ZPETIT)
  91. 55 CONTINUE
  92. IF (NBSOUS.EQ.0) GOTO 60
  93. 50 CONTINUE
  94. 60 CONTINUE
  95. CLONG=MAX(XGRAND-XPETIT,YGRAND-YPETIT,ZGRAND-ZPETIT)
  96. * ON VA ADMETTRE QUE LA DEFORME MAXIMALE EST CLONG/10 ???
  97. COMPMA=0.D0
  98. * BOUCLE DANS LE CHAMP POINT
  99. SEGACT MCHPOI
  100. NSOUPO=IPCHP(/1)
  101. IF (NSOUPO.EQ.0) GOTO 113
  102. DO 100 ISOUPO=1,NSOUPO
  103. MSOUPO=IPCHP(ISOUPO)
  104. SEGACT MSOUPO
  105. MPOVAL=IPOVAL
  106. SEGACT MPOVAL
  107. NC=NOCOMP(/2)
  108. DO 110 I=1,NC
  109. NOC=NOCOMP(I)
  110. DO 120 J=1,IDIM
  111. IF (IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  112. IF (NOC.EQ.NU(J)) GOTO 130
  113. ELSE
  114. IF (NOC.EQ.NV(J)) GOTO 130
  115. ENDIF
  116. GOTO 120
  117. 130 CONTINUE
  118. DO 140 K=1,VPOCHA(/1)
  119. COMPMA=MAX(COMPMA,ABS(VPOCHA(K,I)))
  120. 140 CONTINUE
  121. 120 CONTINUE
  122. 110 CONTINUE
  123. 100 CONTINUE
  124. IF (COMPMA.EQ.0.D0) then
  125. ampl(1)=0
  126. ELSE
  127. AMPL(1)=CLONG/(10*COMPMA)
  128. endif
  129. 1000 CONTINUE
  130. * lecture eventuelle d'un champoint ou d'un chamelem + model
  131. CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU)
  132. if (iretou.eq.1) then
  133. mdchp(1)=mchpoi
  134. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  135. else
  136. CALL LIROBJ('MCHAML ',MCHEL,0,IRETOU)
  137. if (iretou.ne.0) then
  138. CALL ACTOBJ('MCHAML ',MCHEL,1)
  139. CALL LIROBJ('MMODEL ',MODEL,1,IRETOU)
  140. CALL ACTOBJ('MMODEL ',MODEL,1)
  141. if(ierr.ne.0) return
  142. mdmode(1)=model
  143. * PASSER LES CHAMELEM AUX noeuds
  144. CALL CHASUP(MODEL,MCHEL,MCHAM,IRET,1)
  145. IF (IRET.NE.0) MCHAM=MCHEL
  146. mdchel(1)=mcham
  147. endif
  148. endif
  149. SEGDES MDEFOR
  150. RETURN
  151. 113 CONTINUE
  152. CALL ERREUR(475)
  153. END
  154.  
  155.  
  156.  

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