C OPTVOL SOURCE JC220346 16/11/29 21:15:26 9221 C VERIFICATION ET OPTIMISATION VOLUME FABRIQUE PAR DEMETE C SUBROUTINE OPTVOL C C TOUT CE QUE JE SAIT FAIRE C'EST DEPLACER LES NOEUDS C AUX CENTRES DE GRAVITE C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C* Segments inutilises car la boucle 100 ci-dessous n'est pas executee c* SEGMENT XZZ(3,NPT) c* SEGMENT CZZ(NPT) -INC TDEMAIT -INC PPARAM -INC CCOPTIO -INC CCREEL CHARACTER*9 CHA9 CHARACTER*4 MYFMT * * TRAVAIL SUR LES TETRAEDRES * * * DEPLACEMENT DES NOEUDS AU CENTRE DE GRAVITE * COMMENT FAIT ON ??? * C* NPT=NPTMAX-NPTCOM C* SEGINI XZZ,CZZ * DO 100 IFOIS=1,4 C*Mise en commentaire de la boucle 100 puisque executee 0 fois ! C* DO 100 IFOIS=1,0 * C* DO 20 IV=1,NVOL * cCOF=qualt(ivol(1,iv),ivol(2,iv),ivol(3,iv),ivol(4,iv)) C* cCOF=1 C* DO 22 IP=1,8 C* I1=IVOL(IP,IV) C* IF (I1.EQ.0) GOTO 20 C* IF (I1.LE.NPTCOM) GOTO 22 C* DO 24 JP=1,8 C* J1=IVOL(JP,IV) C* IF (J1.EQ.0) GOTO 22 C* IF (J1.EQ.I1) GOTO 24 C* IF (IVOL(9,IV).EQ.35) THEN C* IF (IP.EQ.1.AND.JP.EQ.3) cCOF=2 C* IF (IP.EQ.3.AND.JP.EQ.1) cCOF=2 C* IF (IP.EQ.2.AND.JP.EQ.4) cCOF=2 C* IF (IP.EQ.4.AND.JP.EQ.2) cCOF=2 C* ENDIF C* DO 30 J=1,3 C* XZZ(J,I1-NPTCOM)=XZZ(J,I1-NPTCOM)+cCOF*XYZ(J,J1) C* 30 CONTINUE C* CZZ(I1-NPTCOM)=CZZ(I1-NPTCOM)+cCOF C* 24 CONTINUE C* 22 CONTINUE C* 20 CONTINUE C* DO 40 I=NPTCOM+1,NPTMAX C* DO 42 J=1,3 C* XYZ(J,I)=XZZ(J,I-NPTCOM)/CZZ(I-NPTCOM) C* 42 CONTINUE C* 40 CONTINUE * C* 100 CONTINUE * QUAL=1E10 QUAL1=qual QUAL2=qual1 angm=1.E+6 angm1=angm angm2=angm1 ivv=1 iv1=ivv iv2=iv1 DO 50 IV=1,NVOL IF (IVOL(9,IV).NE.25) GOTO 50 I1=IVOL(1,IV) I2=IVOL(2,IV) I3=IVOL(3,IV) I4=IVOL(4,IV) * VTOT=VOL(I1,I2,I3,I4) * IF (VTOT.LE.0.) WRITE (6,*) ' VOLUME NEGATIF ',IV,i1,i2,i3,i4, * > vtot * VTOT=(VTOT/6.)**0.66666667 * AR1=(XYZ(1,I1)-XYZ(1,I2))**2+(XYZ(2,I1)-XYZ(2,I2))**2 * # +(XYZ(3,I1)-XYZ(3,I2))**2 * AR2=(XYZ(1,I1)-XYZ(1,I3))**2+(XYZ(2,I1)-XYZ(2,I3))**2 * # +(XYZ(3,I1)-XYZ(3,I3))**2 * AR3=(XYZ(1,I4)-XYZ(1,I2))**2+(XYZ(2,I4)-XYZ(2,I2))**2 * # +(XYZ(3,I4)-XYZ(3,I2))**2 * AR4=(XYZ(1,I4)-XYZ(1,I3))**2+(XYZ(2,I4)-XYZ(2,I3))**2 * # +(XYZ(3,I4)-XYZ(3,I3))**2 * AR=MAX(AR1,AR2,AR3,AR4) * QU=AR/VTOT * WRITE (6,*) ' TETRAEDRE ',IV,' QUALITE ',QU,'ELEM ',IVV qu=qualt(i1,i2,i3,i4) if (qu.le.qual) then angm2=angm1 angm1=angm qual2=qual1 qual1=qual QUAL=QU iv2=iv1 iv1=ivv ivv=iv ang1=alpha(i1,i2,i4,i3) if (abs(ang1).lt.xpetit) ang1=xpetit ang2=alpha(i1,i4,i3,i2) if (abs(ang2).lt.xpetit) ang2=xpetit ang3=alpha(i1,i3,i2,i4) if (abs(ang3).lt.xpetit) ang3=xpetit ang4=alpha(i2,i3,i4,i1) if (abs(ang4).lt.xpetit) ang4=xpetit ang5=alpha(i2,i4,i1,i3) if (abs(ang5).lt.xpetit) ang5=xpetit ang6=alpha(i3,i4,i2,i1) if (abs(ang6).lt.xpetit) ang6=xpetit ang1=atan(1/ang1)*180/XPI ang2=atan(1/ang2)*180/XPI ang3=atan(1/ang3)*180/XPI ang4=atan(1/ang4)*180/XPI ang5=atan(1/ang5)*180/XPI ang6=atan(1/ang6)*180/XPI if (ang1.lt.0 ) ang1=ang1+180 if (ang2.lt.0 ) ang2=ang2+180 if (ang3.lt.0 ) ang3=ang3+180 if (ang4.lt.0 ) ang4=ang4+180 if (ang5.lt.0 ) ang5=ang5+180 if (ang6.lt.0 ) ang6=ang6+180 angm=min(ang1,ang2,ang3,ang4,ang5,ang6) goto 50 endif if (qu.le.qual1) then angm2=angm1 ang1=alpha(i1,i2,i4,i3) if (abs(ang1).lt.xpetit) ang1=xpetit ang2=alpha(i1,i4,i3,i2) if (abs(ang2).lt.xpetit) ang2=xpetit ang3=alpha(i1,i3,i2,i4) if (abs(ang3).lt.xpetit) ang3=xpetit ang4=alpha(i2,i3,i4,i1) if (abs(ang4).lt.xpetit) ang4=xpetit ang5=alpha(i2,i4,i1,i3) if (abs(ang5).lt.xpetit) ang5=xpetit ang6=alpha(i3,i4,i2,i1) if (abs(ang6).lt.xpetit) ang6=xpetit ang1=atan(1/ang1)*180/XPI ang2=atan(1/ang2)*180/XPI ang3=atan(1/ang3)*180/XPI ang4=atan(1/ang4)*180/XPI ang5=atan(1/ang5)*180/XPI ang6=atan(1/ang6)*180/XPI if (ang1.lt.0 ) ang1=ang1+180 if (ang2.lt.0 ) ang2=ang2+180 if (ang3.lt.0 ) ang3=ang3+180 if (ang4.lt.0 ) ang4=ang4+180 if (ang5.lt.0 ) ang5=ang5+180 if (ang6.lt.0 ) ang6=ang6+180 angm1=min(ang1,ang2,ang3,ang4,ang5,ang6) qual2=qual1 qual1=qu iv2=iv1 iv1=iv goto 50 endif if (qu.le.qual2) then ang1=alpha(i1,i2,i4,i3) if (abs(ang1).lt.xpetit) ang1=xpetit ang2=alpha(i1,i4,i3,i2) if (abs(ang2).lt.xpetit) ang2=xpetit ang3=alpha(i1,i3,i2,i4) if (abs(ang3).lt.xpetit) ang3=xpetit ang4=alpha(i2,i3,i4,i1) if (abs(ang4).lt.xpetit) ang4=xpetit ang5=alpha(i2,i4,i1,i3) if (abs(ang5).lt.xpetit) ang5=xpetit ang6=alpha(i3,i4,i2,i1) if (abs(ang6).lt.xpetit) ang6=xpetit ang1=atan(1/ang1)*180/XPI ang2=atan(1/ang2)*180/XPI ang3=atan(1/ang3)*180/XPI ang4=atan(1/ang4)*180/XPI ang5=atan(1/ang5)*180/XPI ang6=atan(1/ang6)*180/XPI if (ang1.lt.0 ) ang1=ang1+180 if (ang2.lt.0 ) ang2=ang2+180 if (ang3.lt.0 ) ang3=ang3+180 if (ang4.lt.0 ) ang4=ang4+180 if (ang5.lt.0 ) ang5=ang5+180 if (ang6.lt.0 ) ang6=ang6+180 angm2=min(ang1,ang2,ang3,ang4,ang5,ang6) qual2=qu iv2=iv goto 50 endif 50 CONTINUE * IF (IVERB.EQ.1) THEN WRITE (IOIMP,1000) IVV,QUAL ,angm WRITE (IOIMP,1000) IV1,QUAL1,angm1 WRITE (IOIMP,1000) IV2,QUAL2,angm2 1000 FORMAT(' Elem ',I9,5X,' Qualite min=',E15.8,5X, & ' Angle min=',F8.3,' deg') ELSE IF (ANGM.LE.5.D0.OR.ANGM1.LE.5.D0.OR.ANGM2.LE.5.D0) & WRITE(IOIMP,*) '/!',CHAR(92),' ATTENTION, CERTAINS DES ', & 'ELEMENTS GENERES SONT TRES DEFORMES :' IF (ANGM .LE.5.D0) THEN WRITE(MYFMT,'("(I",I1,")")') INT(LOG10(FLOAT(IVV)))+1 WRITE(CHA9,FMT=MYFMT) IVV WRITE (IOIMP,1001) CHA9,QUAL,angm ENDIF IF (ANGM1.LE.5.D0) THEN WRITE(MYFMT,'("(I",I1,")")') INT(LOG10(FLOAT(IV1)))+1 WRITE(CHA9,FMT=MYFMT) IV1 WRITE (IOIMP,1001) CHA9,QUAL1,ANGM1 ENDIF IF (ANGM2.LE.5.D0) THEN WRITE(MYFMT,'("(I",I1,")")') INT(LOG10(FLOAT(IV2)))+1 WRITE(CHA9,FMT=MYFMT) IV2 WRITE (IOIMP,1001) CHA9,QUAL2,ANGM2 ENDIF 1001 FORMAT(' Elem #',A9,5X,' Qualite min=',E15.8,5X, & ' Angle min=',F8.3,' deg') ENDIF C* SEGSUP XZZ,CZZ RETURN END