Télécharger la plaquette Cast3M


fr en

Télécharger optvol.eso

Retour à la liste

Numérotation des lignes : 

optvol

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

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