Télécharger defo.eso

Retour à la liste

Numérotation des lignes :

  1. C DEFO SOURCE BP208322 16/11/18 21:16:14 9177
  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. C AMPLIFICATION 1 PAR DEFAUT
  21. AMP=1.
  22. CALL LIRREE(AMP,0,IRETOA)
  23. IF (IERR.NE.0) RETURN
  24. MTVE=0
  25. CALL LIROBJ('VECTEUR ',MTVE,0,IRETOU)
  26. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  27. IF (ICOUL.EQ.0) ICOUL=IDCOUL+1
  28. ICOUL=ICOUL-1
  29. C VERIFICATION QU'IL Y A UX UY UZ PARMI LES INCONNUES DU CHPOINT
  30. SEGACT MCHPOI
  31. NSOUPO=IPCHP(/1)
  32. IRAT=1
  33. IF (NSOUPO.EQ.0) GOTO 13
  34. IRAT=1
  35. DO 10 ISOUPO=1,NSOUPO
  36. MSOUPO=IPCHP(ISOUPO)
  37. SEGACT MSOUPO
  38. NC=NOCOMP(/2)
  39. DO 11 I=1,NC
  40. NOC=NOCOMP(I)
  41. DO 12 J=1,IDIM
  42. IF (IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  43. IF (NOC.EQ.NU(J)) IRAT=0
  44. ELSE
  45. IF (NOC.EQ.NV(J)) IRAT=0
  46. ENDIF
  47. 12 CONTINUE
  48. 11 CONTINUE
  49. SEGDES MSOUPO
  50. 10 CONTINUE
  51. SEGDES MCHPOI
  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. SEGDES IPT1
  94. 50 CONTINUE
  95. SEGDES MELEME
  96. 60 CONTINUE
  97. CLONG=MAX(XGRAND-XPETIT,YGRAND-YPETIT,ZGRAND-ZPETIT)
  98. * ON VA ADMETTRE QUE LA DEFORME MAXIMALE EST CLONG/10 ???
  99. COMPMA=0.D0
  100. * BOUCLE DANS LE CHAMP POINT
  101. SEGACT MCHPOI
  102. NSOUPO=IPCHP(/1)
  103. IF (NSOUPO.EQ.0) GOTO 113
  104. DO 100 ISOUPO=1,NSOUPO
  105. MSOUPO=IPCHP(ISOUPO)
  106. SEGACT MSOUPO
  107. MPOVAL=IPOVAL
  108. SEGACT MPOVAL
  109. NC=NOCOMP(/2)
  110. DO 110 I=1,NC
  111. NOC=NOCOMP(I)
  112. DO 120 J=1,IDIM
  113. IF (IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  114. IF (NOC.EQ.NU(J)) GOTO 130
  115. ELSE
  116. IF (NOC.EQ.NV(J)) GOTO 130
  117. ENDIF
  118. GOTO 120
  119. 130 CONTINUE
  120. DO 140 K=1,VPOCHA(/1)
  121. COMPMA=MAX(COMPMA,ABS(VPOCHA(K,I)))
  122. 140 CONTINUE
  123. 120 CONTINUE
  124. 110 CONTINUE
  125. SEGDES MSOUPO,MPOVAL
  126. 100 CONTINUE
  127. SEGDES MCHPOI
  128. IF (COMPMA.EQ.0.D0) then
  129. ampl(1)=0
  130. ELSE
  131. AMPL(1)=CLONG/(10*COMPMA)
  132. endif
  133. 1000 CONTINUE
  134. * lecture eventuelle d'un champoint ou d'un chamelem + model
  135. CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU)
  136. if (iretou.ne.0) mdchp(1)=mchpoi
  137. if (iretou.eq.0) then
  138. CALL LIROBJ('MCHAML ',MCHEL,0,IRETOU)
  139. if (iretou.ne.0) then
  140. CALL LIROBJ('MMODEL ',MODEL,1,IRETOU)
  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. RETURN
  154. END
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  

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