1 : C OPTVOL SOURCE FANDEUR 11/07/19 21:16:52 7039 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 : * TRAVAIL SUR LES TETRAEDRES 19 : * 20 : * 21 : * DEPLACEMENT DES NOEUDS AU CENTRE DE GRAVITE 22 : * COMMENT FAIT ON ??? 23 : * 24 : C* NPT=NPTMAX-NPTCOM 25 : C* SEGINI XZZ,CZZ 26 : * DO 100 IFOIS=1,4 27 : C*Mise en commentaire de la boucle 100 puisque executee 0 fois ! 28 : C* DO 100 IFOIS=1,0 29 : * 30 : C* DO 20 IV=1,NVOL 31 : * cCOF=qualt(ivol(1,iv),ivol(2,iv),ivol(3,iv),ivol(4,iv)) 32 : C* cCOF=1 33 : C* DO 22 IP=1,8 34 : C* I1=IVOL(IP,IV) 35 : C* IF (I1.EQ.0) GOTO 20 36 : C* IF (I1.LE.NPTCOM) GOTO 22 37 : C* DO 24 JP=1,8 38 : C* J1=IVOL(JP,IV) 39 : C* IF (J1.EQ.0) GOTO 22 40 : C* IF (J1.EQ.I1) GOTO 24 41 : C* IF (IVOL(9,IV).EQ.35) THEN 42 : C* IF (IP.EQ.1.AND.JP.EQ.3) cCOF=2 43 : C* IF (IP.EQ.3.AND.JP.EQ.1) cCOF=2 44 : C* IF (IP.EQ.2.AND.JP.EQ.4) cCOF=2 45 : C* IF (IP.EQ.4.AND.JP.EQ.2) cCOF=2 46 : C* ENDIF 47 : C* DO 30 J=1,3 48 : C* XZZ(J,I1-NPTCOM)=XZZ(J,I1-NPTCOM)+cCOF*XYZ(J,J1) 49 : C* 30 CONTINUE 50 : C* CZZ(I1-NPTCOM)=CZZ(I1-NPTCOM)+cCOF 51 : C* 24 CONTINUE 52 : C* 22 CONTINUE 53 : C* 20 CONTINUE 54 : C* DO 40 I=NPTCOM+1,NPTMAX 55 : C* DO 42 J=1,3 56 : C* XYZ(J,I)=XZZ(J,I-NPTCOM)/CZZ(I-NPTCOM) 57 : C* 42 CONTINUE 58 : C* 40 CONTINUE 59 : * 60 : C* 100 CONTINUE 61 : * 62 : QUAL=1E10 63 : QUAL1=qual 64 : QUAL2=qual1 65 : angm=1.E+6 66 : angm1=angm 67 : angm2=angm1 68 : ivv=1 69 : iv1=ivv 70 : iv2=iv1 71 : DO 50 IV=1,NVOL 72 : IF (IVOL(9,IV).NE.25) GOTO 50 73 : I1=IVOL(1,IV) 74 : I2=IVOL(2,IV) 75 : I3=IVOL(3,IV) 76 : I4=IVOL(4,IV) 77 : * VTOT=VOL(I1,I2,I3,I4) 78 : * IF (VTOT.LE.0.) WRITE (6,*) ' VOLUME NEGATIF ',IV,i1,i2,i3,i4, 79 : * > vtot 80 : * VTOT=(VTOT/6.)**0.66666667 81 : * AR1=(XYZ(1,I1)-XYZ(1,I2))**2+(XYZ(2,I1)-XYZ(2,I2))**2 82 : * # +(XYZ(3,I1)-XYZ(3,I2))**2 83 : * AR2=(XYZ(1,I1)-XYZ(1,I3))**2+(XYZ(2,I1)-XYZ(2,I3))**2 84 : * # +(XYZ(3,I1)-XYZ(3,I3))**2 85 : * AR3=(XYZ(1,I4)-XYZ(1,I2))**2+(XYZ(2,I4)-XYZ(2,I2))**2 86 : * # +(XYZ(3,I4)-XYZ(3,I2))**2 87 : * AR4=(XYZ(1,I4)-XYZ(1,I3))**2+(XYZ(2,I4)-XYZ(2,I3))**2 88 : * # +(XYZ(3,I4)-XYZ(3,I3))**2 89 : * AR=MAX(AR1,AR2,AR3,AR4) 90 : * QU=AR/VTOT 91 : * WRITE (6,*) ' TETRAEDRE ',IV,' QUALITE ',QU,'ELEM ',IVV 92 : qu=qualt(i1,i2,i3,i4) 93 : if (qu.le.qual) then 94 : angm2=angm1 95 : angm1=angm 96 : qual2=qual1 97 : qual1=qual 98 : QUAL=QU 99 : iv2=iv1 100 : iv1=ivv 101 : ivv=iv 102 : ang1=alpha(i1,i2,i4,i3) 103 : ang2=alpha(i1,i4,i3,i2) 104 : ang3=alpha(i1,i3,i2,i4) 105 : ang4=alpha(i2,i3,i4,i1) 106 : ang5=alpha(i2,i4,i1,i3) 107 : ang6=alpha(i3,i4,i2,i1) 108 : ang1=atan(1/alpha(i1,i2,i4,i3))*180/XPI 109 : ang2=atan(1/alpha(i1,i4,i3,i2))*180/XPI 110 : ang3=atan(1/alpha(i1,i3,i2,i4))*180/XPI 111 : ang4=atan(1/alpha(i2,i3,i4,i1))*180/XPI 112 : ang5=atan(1/alpha(i2,i4,i1,i3))*180/XPI 113 : ang6=atan(1/alpha(i3,i4,i2,i1))*180/XPI 114 : if (ang1.lt.0 ) ang1=ang1+180 115 : if (ang2.lt.0 ) ang2=ang2+180 116 : if (ang3.lt.0 ) ang3=ang3+180 117 : if (ang4.lt.0 ) ang4=ang4+180 118 : if (ang5.lt.0 ) ang5=ang5+180 119 : if (ang6.lt.0 ) ang6=ang6+180 120 : angm=min(ang1,ang2,ang3,ang4,ang5,ang6) 121 : goto 50 122 : endif 123 : if (qu.le.qual1) then 124 : angm2=angm1 125 : ang1=atan(1/alpha(i1,i2,i4,i3))*180/XPI 126 : ang2=atan(1/alpha(i1,i4,i3,i2))*180/XPI 127 : ang3=atan(1/alpha(i1,i3,i2,i4))*180/XPI 128 : ang4=atan(1/alpha(i2,i3,i4,i1))*180/XPI 129 : ang5=atan(1/alpha(i2,i4,i1,i3))*180/XPI 130 : ang6=atan(1/alpha(i3,i4,i2,i1))*180/XPI 131 : if (ang1.lt.0 ) ang1=ang1+180 132 : if (ang2.lt.0 ) ang2=ang2+180 133 : if (ang3.lt.0 ) ang3=ang3+180 134 : if (ang4.lt.0 ) ang4=ang4+180 135 : if (ang5.lt.0 ) ang5=ang5+180 136 : if (ang6.lt.0 ) ang6=ang6+180 137 : angm1=min(ang1,ang2,ang3,ang4,ang5,ang6) 138 : qual2=qual1 139 : qual1=qu 140 : iv2=iv1 141 : iv1=iv 142 : goto 50 143 : endif 144 : if (qu.le.qual2) then 145 : ang1=atan(1/alpha(i1,i2,i4,i3))*180/XPI 146 : ang2=atan(1/alpha(i1,i4,i3,i2))*180/XPI 147 : ang3=atan(1/alpha(i1,i3,i2,i4))*180/XPI 148 : ang4=atan(1/alpha(i2,i3,i4,i1))*180/XPI 149 : ang5=atan(1/alpha(i2,i4,i1,i3))*180/XPI 150 : ang6=atan(1/alpha(i3,i4,i2,i1))*180/XPI 151 : if (ang1.lt.0 ) ang1=ang1+180 152 : if (ang2.lt.0 ) ang2=ang2+180 153 : if (ang3.lt.0 ) ang3=ang3+180 154 : if (ang4.lt.0 ) ang4=ang4+180 155 : if (ang5.lt.0 ) ang5=ang5+180 156 : if (ang6.lt.0 ) ang6=ang6+180 157 : angm2=min(ang1,ang2,ang3,ang4,ang5,ang6) 158 : qual2=qu 159 : iv2=iv 160 : goto 50 161 : endif 162 : 50 CONTINUE 163 : WRITE (6,*) ' Qualite min ',QUAL ,' Elem ',IVV,' Angle min ',angm 164 : WRITE (6,*) ' Qualite min ',QUAL1,' Elem ',IV1,' Angle min ',angm1 165 : WRITE (6,*) ' Qualite min ',QUAL2,' Elem ',IV2,' Angle min ',angm2 166 : C* SEGSUP XZZ,CZZ 167 : RETURN 168 : END 169 : 170 :
© Cast3M 2003 - All rights reserved.
Disclaimer