Télécharger optvol.eso

Retour à la liste

Numérotation des lignes :

  1. C OPTVOL SOURCE JC220346 16/11/29 21:15:26 9221
  2. C VERIFICATION ET OPTIMISATION VOLUME FABRIQUE PAR DEMETE
  3. C
  4. SUBROUTINE OPTVOL
  5. C
  6. C TOUT CE QUE JE SAIT FAIRE C'EST DEPLACER LES NOEUDS
  7. C AUX CENTRES DE GRAVITE
  8. C
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8(A-H,O-Z)
  11. C* Segments inutilises car la boucle 100 ci-dessous n'est pas executee
  12. c* SEGMENT XZZ(3,NPT)
  13. c* SEGMENT CZZ(NPT)
  14. -INC TDEMAIT
  15. -INC CCOPTIO
  16. -INC CCREEL
  17.  
  18. CHARACTER*9 CHA9
  19. CHARACTER*4 MYFMT
  20. *
  21. * TRAVAIL SUR LES TETRAEDRES
  22. *
  23. *
  24. * DEPLACEMENT DES NOEUDS AU CENTRE DE GRAVITE
  25. * COMMENT FAIT ON ???
  26. *
  27. C* NPT=NPTMAX-NPTCOM
  28. C* SEGINI XZZ,CZZ
  29. * DO 100 IFOIS=1,4
  30. C*Mise en commentaire de la boucle 100 puisque executee 0 fois !
  31. C* DO 100 IFOIS=1,0
  32. *
  33. C* DO 20 IV=1,NVOL
  34. * cCOF=qualt(ivol(1,iv),ivol(2,iv),ivol(3,iv),ivol(4,iv))
  35. C* cCOF=1
  36. C* DO 22 IP=1,8
  37. C* I1=IVOL(IP,IV)
  38. C* IF (I1.EQ.0) GOTO 20
  39. C* IF (I1.LE.NPTCOM) GOTO 22
  40. C* DO 24 JP=1,8
  41. C* J1=IVOL(JP,IV)
  42. C* IF (J1.EQ.0) GOTO 22
  43. C* IF (J1.EQ.I1) GOTO 24
  44. C* IF (IVOL(9,IV).EQ.35) THEN
  45. C* IF (IP.EQ.1.AND.JP.EQ.3) cCOF=2
  46. C* IF (IP.EQ.3.AND.JP.EQ.1) cCOF=2
  47. C* IF (IP.EQ.2.AND.JP.EQ.4) cCOF=2
  48. C* IF (IP.EQ.4.AND.JP.EQ.2) cCOF=2
  49. C* ENDIF
  50. C* DO 30 J=1,3
  51. C* XZZ(J,I1-NPTCOM)=XZZ(J,I1-NPTCOM)+cCOF*XYZ(J,J1)
  52. C* 30 CONTINUE
  53. C* CZZ(I1-NPTCOM)=CZZ(I1-NPTCOM)+cCOF
  54. C* 24 CONTINUE
  55. C* 22 CONTINUE
  56. C* 20 CONTINUE
  57. C* DO 40 I=NPTCOM+1,NPTMAX
  58. C* DO 42 J=1,3
  59. C* XYZ(J,I)=XZZ(J,I-NPTCOM)/CZZ(I-NPTCOM)
  60. C* 42 CONTINUE
  61. C* 40 CONTINUE
  62. *
  63. C* 100 CONTINUE
  64. *
  65. QUAL=1E10
  66. QUAL1=qual
  67. QUAL2=qual1
  68. angm=1.E+6
  69. angm1=angm
  70. angm2=angm1
  71. ivv=1
  72. iv1=ivv
  73. iv2=iv1
  74. DO 50 IV=1,NVOL
  75. IF (IVOL(9,IV).NE.25) GOTO 50
  76. I1=IVOL(1,IV)
  77. I2=IVOL(2,IV)
  78. I3=IVOL(3,IV)
  79. I4=IVOL(4,IV)
  80. * VTOT=VOL(I1,I2,I3,I4)
  81. * IF (VTOT.LE.0.) WRITE (6,*) ' VOLUME NEGATIF ',IV,i1,i2,i3,i4,
  82. * > vtot
  83. * VTOT=(VTOT/6.)**0.66666667
  84. * AR1=(XYZ(1,I1)-XYZ(1,I2))**2+(XYZ(2,I1)-XYZ(2,I2))**2
  85. * # +(XYZ(3,I1)-XYZ(3,I2))**2
  86. * AR2=(XYZ(1,I1)-XYZ(1,I3))**2+(XYZ(2,I1)-XYZ(2,I3))**2
  87. * # +(XYZ(3,I1)-XYZ(3,I3))**2
  88. * AR3=(XYZ(1,I4)-XYZ(1,I2))**2+(XYZ(2,I4)-XYZ(2,I2))**2
  89. * # +(XYZ(3,I4)-XYZ(3,I2))**2
  90. * AR4=(XYZ(1,I4)-XYZ(1,I3))**2+(XYZ(2,I4)-XYZ(2,I3))**2
  91. * # +(XYZ(3,I4)-XYZ(3,I3))**2
  92. * AR=MAX(AR1,AR2,AR3,AR4)
  93. * QU=AR/VTOT
  94. * WRITE (6,*) ' TETRAEDRE ',IV,' QUALITE ',QU,'ELEM ',IVV
  95. qu=qualt(i1,i2,i3,i4)
  96. if (qu.le.qual) then
  97. angm2=angm1
  98. angm1=angm
  99. qual2=qual1
  100. qual1=qual
  101. QUAL=QU
  102. iv2=iv1
  103. iv1=ivv
  104. ivv=iv
  105. ang1=alpha(i1,i2,i4,i3)
  106. if (abs(ang1).lt.xpetit) ang1=xpetit
  107. ang2=alpha(i1,i4,i3,i2)
  108. if (abs(ang2).lt.xpetit) ang2=xpetit
  109. ang3=alpha(i1,i3,i2,i4)
  110. if (abs(ang3).lt.xpetit) ang3=xpetit
  111. ang4=alpha(i2,i3,i4,i1)
  112. if (abs(ang4).lt.xpetit) ang4=xpetit
  113. ang5=alpha(i2,i4,i1,i3)
  114. if (abs(ang5).lt.xpetit) ang5=xpetit
  115. ang6=alpha(i3,i4,i2,i1)
  116. if (abs(ang6).lt.xpetit) ang6=xpetit
  117. ang1=atan(1/ang1)*180/XPI
  118. ang2=atan(1/ang2)*180/XPI
  119. ang3=atan(1/ang3)*180/XPI
  120. ang4=atan(1/ang4)*180/XPI
  121. ang5=atan(1/ang5)*180/XPI
  122. ang6=atan(1/ang6)*180/XPI
  123. if (ang1.lt.0 ) ang1=ang1+180
  124. if (ang2.lt.0 ) ang2=ang2+180
  125. if (ang3.lt.0 ) ang3=ang3+180
  126. if (ang4.lt.0 ) ang4=ang4+180
  127. if (ang5.lt.0 ) ang5=ang5+180
  128. if (ang6.lt.0 ) ang6=ang6+180
  129. angm=min(ang1,ang2,ang3,ang4,ang5,ang6)
  130. goto 50
  131. endif
  132. if (qu.le.qual1) then
  133. angm2=angm1
  134. ang1=alpha(i1,i2,i4,i3)
  135. if (abs(ang1).lt.xpetit) ang1=xpetit
  136. ang2=alpha(i1,i4,i3,i2)
  137. if (abs(ang2).lt.xpetit) ang2=xpetit
  138. ang3=alpha(i1,i3,i2,i4)
  139. if (abs(ang3).lt.xpetit) ang3=xpetit
  140. ang4=alpha(i2,i3,i4,i1)
  141. if (abs(ang4).lt.xpetit) ang4=xpetit
  142. ang5=alpha(i2,i4,i1,i3)
  143. if (abs(ang5).lt.xpetit) ang5=xpetit
  144. ang6=alpha(i3,i4,i2,i1)
  145. if (abs(ang6).lt.xpetit) ang6=xpetit
  146. ang1=atan(1/ang1)*180/XPI
  147. ang2=atan(1/ang2)*180/XPI
  148. ang3=atan(1/ang3)*180/XPI
  149. ang4=atan(1/ang4)*180/XPI
  150. ang5=atan(1/ang5)*180/XPI
  151. ang6=atan(1/ang6)*180/XPI
  152. if (ang1.lt.0 ) ang1=ang1+180
  153. if (ang2.lt.0 ) ang2=ang2+180
  154. if (ang3.lt.0 ) ang3=ang3+180
  155. if (ang4.lt.0 ) ang4=ang4+180
  156. if (ang5.lt.0 ) ang5=ang5+180
  157. if (ang6.lt.0 ) ang6=ang6+180
  158. angm1=min(ang1,ang2,ang3,ang4,ang5,ang6)
  159. qual2=qual1
  160. qual1=qu
  161. iv2=iv1
  162. iv1=iv
  163. goto 50
  164. endif
  165. if (qu.le.qual2) then
  166. ang1=alpha(i1,i2,i4,i3)
  167. if (abs(ang1).lt.xpetit) ang1=xpetit
  168. ang2=alpha(i1,i4,i3,i2)
  169. if (abs(ang2).lt.xpetit) ang2=xpetit
  170. ang3=alpha(i1,i3,i2,i4)
  171. if (abs(ang3).lt.xpetit) ang3=xpetit
  172. ang4=alpha(i2,i3,i4,i1)
  173. if (abs(ang4).lt.xpetit) ang4=xpetit
  174. ang5=alpha(i2,i4,i1,i3)
  175. if (abs(ang5).lt.xpetit) ang5=xpetit
  176. ang6=alpha(i3,i4,i2,i1)
  177. if (abs(ang6).lt.xpetit) ang6=xpetit
  178. ang1=atan(1/ang1)*180/XPI
  179. ang2=atan(1/ang2)*180/XPI
  180. ang3=atan(1/ang3)*180/XPI
  181. ang4=atan(1/ang4)*180/XPI
  182. ang5=atan(1/ang5)*180/XPI
  183. ang6=atan(1/ang6)*180/XPI
  184. if (ang1.lt.0 ) ang1=ang1+180
  185. if (ang2.lt.0 ) ang2=ang2+180
  186. if (ang3.lt.0 ) ang3=ang3+180
  187. if (ang4.lt.0 ) ang4=ang4+180
  188. if (ang5.lt.0 ) ang5=ang5+180
  189. if (ang6.lt.0 ) ang6=ang6+180
  190. angm2=min(ang1,ang2,ang3,ang4,ang5,ang6)
  191. qual2=qu
  192. iv2=iv
  193. goto 50
  194. endif
  195. 50 CONTINUE
  196. *
  197. IF (IVERB.EQ.1) THEN
  198. WRITE (IOIMP,1000) IVV,QUAL ,angm
  199. WRITE (IOIMP,1000) IV1,QUAL1,angm1
  200. WRITE (IOIMP,1000) IV2,QUAL2,angm2
  201. 1000 FORMAT(' Elem ',I9,5X,' Qualite min=',E15.8,5X,
  202. & ' Angle min=',F8.3,' deg')
  203. ELSE
  204. IF (ANGM.LE.5.D0.OR.ANGM1.LE.5.D0.OR.ANGM2.LE.5.D0)
  205. & WRITE(IOIMP,*) '/!',CHAR(92),' ATTENTION, CERTAINS DES ',
  206. & 'ELEMENTS GENERES SONT TRES DEFORMES :'
  207. IF (ANGM .LE.5.D0) THEN
  208. WRITE(MYFMT,'("(I",I1,")")') INT(LOG10(FLOAT(IVV)))+1
  209. WRITE(CHA9,FMT=MYFMT) IVV
  210. WRITE (IOIMP,1001) CHA9,QUAL,angm
  211. ENDIF
  212. IF (ANGM1.LE.5.D0) THEN
  213. WRITE(MYFMT,'("(I",I1,")")') INT(LOG10(FLOAT(IV1)))+1
  214. WRITE(CHA9,FMT=MYFMT) IV1
  215. WRITE (IOIMP,1001) CHA9,QUAL1,ANGM1
  216. ENDIF
  217. IF (ANGM2.LE.5.D0) THEN
  218. WRITE(MYFMT,'("(I",I1,")")') INT(LOG10(FLOAT(IV2)))+1
  219. WRITE(CHA9,FMT=MYFMT) IV2
  220. WRITE (IOIMP,1001) CHA9,QUAL2,ANGM2
  221. ENDIF
  222. 1001 FORMAT(' Elem #',A9,5X,' Qualite min=',E15.8,5X,
  223. & ' Angle min=',F8.3,' deg')
  224. ENDIF
  225. C* SEGSUP XZZ,CZZ
  226. RETURN
  227. END
  228.  
  229.  
  230.  
  231.  
  232.  

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