Télécharger defo.eso

Retour à la liste

Numérotation des lignes :

defo
  1. C DEFO SOURCE PASCAL 21/02/11 21:15:09 10890
  2. ************************************************************************
  3. C CONSTRUCTION D'UN OBJET DE TYPE DEFORME A PARTIR D'UNE GEOMETRIE
  4. C D'UN CHPOIN UX UY UZ ET D'UN COEF D'AMPLIFICATION
  5. C 1995 Changement de defaut de couleur P.PEGON JRC-ISPRA
  6. C
  7. ************************************************************************
  8.  
  9. SUBROUTINE DEFO
  10. IMPLICIT INTEGER(I-N)
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC CCGEOME
  15. -INC SMCHPOI
  16. -INC SMDEFOR
  17. -INC SMCOORD
  18. -INC SMELEME
  19. -INC CCREEL
  20.  
  21. CHARACTER*(LOCOMP) NOC,NU(3),NV(3)
  22. REAL*8 AMP,CLONG,UMAX(3)
  23.  
  24. DATA NU/'UX ','UY ','UZ '/
  25. DATA NV/'UR ','UZ ','UT '/
  26.  
  27.  
  28. ************************************************************************
  29. * LECTURE
  30. ************************************************************************
  31.  
  32. * MAILLAGE ET CHPOINT SONT OBLIGATOIRES
  33. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  34. CALL LIROBJ('CHPOINT ',MCHPOI,1,IRETOU)
  35. CALL ACTOBJ('MAILLAGE',MELEME,1)
  36. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  37. segact mcoord
  38.  
  39. C AMPLIFICATION 1 PAR DEFAUT
  40. AMP=1.D0
  41. CALL LIRREE(AMP,0,IRETOA)
  42. IF (IERR.NE.0) RETURN
  43.  
  44. c VECTEUR
  45. MTVE=0
  46. CALL LIROBJ('VECTEUR ',MTVE,0,IRETOU)
  47.  
  48. c COULEUR
  49. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  50. IF (ICOUL.EQ.0) ICOUL=IDCOUL+1
  51. ICOUL=ICOUL-1
  52.  
  53.  
  54. ************************************************************************
  55. * TRAVAIL SUR LE CHPOINT
  56. ************************************************************************
  57.  
  58. C VERIFICATION QU'IL Y A UX UY UZ PARMI LES INCONNUES DU CHPOINT
  59. c SEGACT MCHPOI
  60. NSOUPO=IPCHP(/1)
  61. IRAT=1
  62. IF (NSOUPO.EQ.0) GOTO 13
  63. IRAT=1
  64. DO 10 ISOUPO=1,NSOUPO
  65. MSOUPO=IPCHP(ISOUPO)
  66. c SEGACT MSOUPO
  67. NC=NOCOMP(/2)
  68. DO 11 I=1,NC
  69. NOC=NOCOMP(I)
  70. DO 12 J=1,IDIM
  71. IF (IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  72. IF (NOC.EQ.NU(J)) IRAT=0
  73. ELSE
  74. IF (NOC.EQ.NV(J)) IRAT=0
  75. ENDIF
  76. 12 CONTINUE
  77. 11 CONTINUE
  78. 10 CONTINUE
  79. c ERREUR SUR LES COMPOSANTES
  80. IF (IRAT.EQ.1) CALL ERREUR(184)
  81. 13 CONTINUE
  82.  
  83.  
  84. ************************************************************************
  85. * TRAVAIL SUR L'AMPLIFICATION
  86. ************************************************************************
  87.  
  88. IF (IRETOA.EQ.0) THEN
  89.  
  90. **** CALCUL D'UNE LONGUEUR CARACTERISTIQUE : CLONG ****
  91. c rem : pas besoin de CCREEL car ces valeurs seront tres vite ecrasees
  92. XMAX=-XSGRAN
  93. XMIN= XSGRAN
  94. YMAX=-XSGRAN
  95. YMIN= XSGRAN
  96. *bp,2021 : ajout pour le cas 2D
  97. if(idim.eq.3) then
  98. ZMAX=-XSGRAN
  99. ZMIN= XSGRAN
  100. else
  101. ZMAX=0.D0
  102. ZMIN=0.D0
  103. endif
  104. * CALCUL DU CADRE
  105. SEGACT MELEME
  106. NBSOUS=LISOUS(/1)
  107. IPT1=MELEME
  108. DO 50 ISOUS=1,MAX0(1,NBSOUS)
  109. IF (NBSOUS.NE.0) IPT1=LISOUS(ISOUS)
  110. SEGACT IPT1
  111. DO 55 J=1,IPT1.NUM(/2)
  112. DO 56 I=1,IPT1.NUM(/1)
  113. IPT=IPT1.NUM(I,J)
  114. IREF=(IDIM+1)*(IPT-1)
  115. XPT=XCOOR(IREF+1)
  116. XMAX=MAX(XPT,XMAX)
  117. XMIN=MIN(XPT,XMIN)
  118. YPT=XCOOR(IREF+2)
  119. YMAX=MAX(YPT,YMAX)
  120. YMIN=MIN(YPT,YMIN)
  121. IF(IDIM.EQ.3) THEN
  122. ZPT=XCOOR(IREF+3)
  123. ZMAX=MAX(ZPT,ZMAX)
  124. ZMIN=MIN(ZPT,ZMIN)
  125. ENDIF
  126. 56 CONTINUE
  127. 55 CONTINUE
  128. IF (NBSOUS.EQ.0) GOTO 60
  129. 50 CONTINUE
  130. 60 CONTINUE
  131. c CLONG=MAX(XMAX-XMIN,YMAX-YMIN,ZMAX-ZMIN)
  132. *bp,2021 : une norme 2 semble + adaptee
  133. CLONG=SQRT((XMAX-XMIN)**2+(YMAX-YMIN)**2+(ZMAX-ZMIN)**2)
  134.  
  135. **** CALCUL DU DEPLACEMENT MAX : UMAX ****
  136. UMAX(1)=0.D0
  137. UMAX(2)=0.D0
  138. UMAX(3)=0.D0
  139. c SEGACT MCHPOI
  140. NSOUPO=IPCHP(/1)
  141. IF (NSOUPO.EQ.0) THEN
  142. c "Impossible de calculer le coefficient d'amplification"
  143. CALL ERREUR(475)
  144. RETURN
  145. ENDIF
  146. DO 100 ISOUPO=1,NSOUPO
  147. MSOUPO=IPCHP(ISOUPO)
  148. c SEGACT MSOUPO
  149. MPOVAL=IPOVAL
  150. c SEGACT MPOVAL
  151. NC=NOCOMP(/2)
  152. DO 110 I=1,NC
  153. NOC=NOCOMP(I)
  154. DO 120 J=1,IDIM
  155. IF (IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  156. IF (NOC.EQ.NU(J)) GOTO 130
  157. ELSE
  158. IF (NOC.EQ.NV(J)) GOTO 130
  159. ENDIF
  160. GOTO 120
  161. c Jeme composante trouvee
  162. 130 CONTINUE
  163. DO 140 K=1,VPOCHA(/1)
  164. UMAX(J)=MAX(UMAX(J),ABS(VPOCHA(K,I)))
  165. 140 CONTINUE
  166. 120 CONTINUE
  167. 110 CONTINUE
  168. 100 CONTINUE
  169. COMPMA=SQRT(UMAX(1)**2+UMAX(2)**2+UMAX(3)**2)
  170.  
  171. * ON PREND CLONG/(10*UMAX) COMME AMPLIFICATION
  172. IF(COMPMA.GE.XSPETI) AMP=CLONG/(10.D0*COMPMA)
  173. c (sinon, AMP reste = 1.d0)
  174.  
  175. ENDIF
  176.  
  177.  
  178. ************************************************************************
  179. * ISOVALEUR via CHPOINT ou MCHAML
  180. ************************************************************************
  181. IPCHP1=0
  182. IPCHEL=0
  183. IPMODL=0
  184. IPCHAM=0
  185. * lecture eventuelle d'un 2nd champoint ou d'un chamelem + model
  186. CALL LIROBJ('CHPOINT ',IPCHP1,0,IRETOU)
  187. if (iretou.eq.1) then
  188. c mdchp(1)=IPCHP1
  189. CALL ACTOBJ('CHPOINT ',IPCHP1,1)
  190. else
  191. CALL LIROBJ('MCHAML ',IPCHEL,0,IRETOU)
  192. if (iretou.ne.0) then
  193. CALL ACTOBJ('MCHAML ',IPCHEL,1)
  194. CALL LIROBJ('MMODEL ',IPMODL,1,IRETOU)
  195. CALL ACTOBJ('MMODEL ',IPMODL,1)
  196. if(ierr.ne.0) return
  197. c mdmode(1)=IPMODL
  198. * PASSER LES CHAMELEM AUX noeuds
  199. CALL CHASUP(IPMODL,IPCHEL,IPCHAM,IRET,1)
  200. IF (IRET.NE.0) IPCHAM=IPCHEL
  201. c mdchel(1)=IPCHAM
  202. endif
  203. endif
  204. * rem : on pourrait verifier ici que ces champs n'ont qu'une seule
  205. * composante car TRAC ne sait pas traiter autrement a ce jour
  206.  
  207.  
  208. ************************************************************************
  209. * CREATION ET ECRITURE DE LA DEFORMEE
  210. ************************************************************************
  211.  
  212. NDEF=1
  213. SEGINI MDEFOR
  214. AMPL(1)=AMP
  215. MTVECT(1)=MTVE
  216. IELDEF(1)=MELEME
  217. ICHDEF(1)=MCHPOI
  218. JCOUL(1)=ICOUL
  219. if(IPCHP1.ne.0) then
  220. mdchp(1)=IPCHP1
  221. elseif(IPCHEL.ne.0) then
  222. mdmode(1)=IPMODL
  223. mdchel(1)=IPCHAM
  224. endif
  225. CALL ECROBJ('DEFORME ',MDEFOR)
  226. c SEGDES MDEFOR
  227.  
  228. END
  229.  
  230.  
  231.  
  232.  
  233.  

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