SUBROUTINE RVSDIAG ! routine to test for and reverse diagonals USE BLK1MOD USE BLK2MOD INCLUDE 'BFILES.I90' REAL IGrDistanceLine dist(n1,n2)=sqrt((xusr(n1)-xusr(n2))**2+(yusr(n1)-yusr(n2))**2) ! save current file IFILOUT=IACTVFIL+50 CALL WRTFIL(IFILOUT) ! fill midsides CALL FILM(1) ! get elements connected to nodes table MIDSIDE=0 IERR=1 CALL NDNECON(IERR) ! gets nodes nodes opposite ! loop on midsides KCOUNT=0 DO N=1,NP IF(NECON(N,2) .EQ. 0) CYCLE NEL1=NECON(N,1) NEL2=NECON(N,2) WRITE(160,*) 'ELTS',NEL1,NEL2 ! test for two triangles IF(NCORN(NEL1) .EQ. 8 .OR. NCORN(NEL1) .LT. 6) CYCLE IF(NCORN(NEL2) .EQ. 8 .OR. NCORN(NEL2) .LT. 6) CYCLE ! get the adjacent nodes N1 and N2 DO K=2,6,2 IF(N .EQ. NOP(NEL1,K)) THEN ! get the adjacent nodes N1 and N2 N1=NOP(NEL1,K-1) N2=K+1 IF(N2 .GT. 6) N2=1 N2=NOP(NEL1,N2) ! get first of two nodes facing each other N3 N3=K+3 IF(N3 .GT. 6) N3=N3-6 N3=NOP(NEL1,N3) ENDIF ENDDO ! get second of two nodes facing each other N4 DO K=2,6,2 IF(N .EQ. NOP(NEL2,K)) THEN N4=K+3 IF(N4 .GT. 6) N4=N4-6 N4=NOP(NEL2,N4) ENDIF ENDDO IF(WD(N1) .EQ. WD(N3) .AND. WD(N2) .EQ. WD(N3)) GO TO 500 IF(WD(N1) .EQ. WD(N4) .AND. WD(N2) .EQ. WD(N4)) GO TO 500 IF(WD(N1) .EQ. WD(N3) .AND. WD(N1) .EQ. WD(N4)) GO TO 500 IF(WD(N2) .EQ. WD(N3) .AND. WD(N2) .EQ. WD(N4)) GO TO 500 X1=XUSR(N1) X2=XUSR(N2) X3=XUSR(N3) X4=XUSR(N4) Y1=YUSR(N1) Y2=YUSR(N2) Y3=YUSR(N3) Y4=YUSR(N4) CALL IGRINTERSECTLINE(X1,Y1,X2,Y2,X3,Y3,X4,Y4,XINTER,YINTER,ISTAT) IF(ISTAT .NE. 5) GO TO 500 METHOD=1 D1=IGrDistanceLine(X1,Y1,X2,Y2,XINTER,YINTER,METHOD) ! D2=IGrDistanceLine(X1,Y1,X2,Y2,X4,Y4,METHOD) D1=SQRT((X1-XINTER)**2+(Y1-YINTER)**2) D2=SQRT((X2-XINTER)**2+(Y2-YINTER)**2) D3=SQRT((X1-X2)**2+(Y1-Y2)**2) IF(D1 .LT. 0.05*D3) GO TO 500 IF(D2 .LT. 0.05*D3) GO TO 500 IF(WD(N3) .EQ. WD(N1)) THEN IF(ABS(WD(N4)-WD(N3)) .LT. ABS(WD(N2)-WD(N3))) THEN KCOUNT=KCOUNT+1 WRITE(160,*) 'QV1',KCOUNT,NEL1,NEL2,N1,N2,N3,N4 CALL DUMPBIN(KCOUNT,1) CALL REVERS(NEL1,NEL2) GO TO 500 ELSE GO TO 500 ENDIF ELSEIF(WD(N3) .EQ. WD(N2)) THEN IF(ABS(WD(N4)-WD(N3)) .LT. ABS(WD(N3)-WD(N2))) THEN KCOUNT=KCOUNT+1 WRITE(160,*) 'QV2',KCOUNT,NEL1,NEL2,N1,N2,N3,N4 CALL DUMPBIN(KCOUNT,1) CALL REVERS(NEL1,NEL2) GO TO 500 ELSE GO TO 500 ENDIF ENDIF ! test if they are equal height IF(WD(N3) .EQ. WD(N4) .or. ABS(WD(N3) -WD(N4)) .LT. ABS(WD(N1)-WD(N2))) THEN ! if so reverse connections if(dist(n1,n2)*1.5 .lt. dist(n3,n4)) go to 500 KCOUNT=KCOUNT+1 WRITE(160,*) 'RV1',KCOUNT,NEL1,NEL2,N1,N2,N3,N4 CALL REVERS(NEL1,NEL2) CALL DUMPBIN(KCOUNT,1) ELSE ! test if N4 closer or equal to N3 than N1 or N2 IF(ABS(WD(N4) - WD(N3)) .LT. ABS(WD(N1) - WD(N3)) .OR. ABS(WD(N4) - WD(N3)) .LT. ABS(WD(N2) - WD(N3))) THEN ! if so reverse connections if(dist(n1,n2)*1.5 .lt. dist(n3,n4)) go to 500 KCOUNT=KCOUNT+1 WRITE(160,*) 'RV2',KCOUNT,NEL1,NEL2,N1,N2,N3,N4 CALL REVERS(NEL1,NEL2) CALL DUMPBIN(KCOUNT,1) ENDIF ENDIF 500 CONTINUE ! end loop ENDDO RETURN END