extrac.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\stbtel\extrac.f
00002 !
00023                         SUBROUTINE EXTRAC
00024 !                       *****************
00025 !
00026      &(X,Y,SOM,IKLE,INDIC,NELEM,NELMAX,NPOIN,NSOM,PROJEC)
00027 !
00028 !***********************************************************************
00029 ! PROGICIEL : STBTEL V5.2    07/12/88    J-M HERVOUET (LNH) 30 87 80 18
00030 !                            19/02/93    J-M JANIN    (LNH) 30 87 72 84
00031 !                                        A   WATRIN
00032 !***********************************************************************
00033 !
00034 !  FONCTION  :  PREPARATION DE DONNEES AVANT L'APPEL DE FMTSEL
00035 !
00036 !-----------------------------------------------------------------------
00037 !                             ARGUMENTS
00038 ! .________________.____.______________________________________________
00039 ! !      NOM       !MODE!                   ROLE
00040 ! !________________!____!______________________________________________
00041 ! !________________!____!______________________________________________
00042 ! MODE : -->(DONNEE NON MODIFIEE), <--(RESULTAT), <-->(DONNEE MODIFIEE)
00043 !-----------------------------------------------------------------------
00044 !
00045 ! APPELE PAR : PREDON
00046 ! APPEL DE : -
00047 !
00048 !***********************************************************************
00049 !
00050       IMPLICIT NONE
00051       INTEGER LNG,LU
00052       COMMON/INFO/LNG,LU
00053 !
00054       INTEGER NELEM,NELMAX,NPOIN,NSOM,IELEM,IPOIN,ISOM,IDP,I1,I2,I3
00055       INTEGER IKLE(NELMAX,3),INDIC(NPOIN)
00056 !
00057       DOUBLE PRECISION X(NPOIN),Y(NPOIN),SOM(10,2),DX,DY,A1,A2,A3
00058 !
00059       LOGICAL PROJEC,FLAG,F1,F2,F3
00060 !
00061 !=======================================================================
00062 ! BOUCLE SUR TOUS LES PLANS DE COUPE
00063 !=======================================================================
00064 !
00065       DO ISOM = 1,NSOM
00066 !
00067         DX = SOM(ISOM+1,1) - SOM(ISOM,1)
00068         DY = SOM(ISOM+1,2) - SOM(ISOM,2)
00069 !
00070 !=======================================================================
00071 ! POUR UN DEMI PLAN DE COUPE DONNE :
00072 !      RECHERCHE DES POINTS EXT.(=0) , INT.(=1) , SUR LE BORD (=2)
00073 !=======================================================================
00074 !
00075         DO IPOIN = 1,NPOIN
00076           INDIC(IPOIN) = 0
00077           IF (DX*(Y(IPOIN)-SOM(ISOM,2)).GE.DY*(X(IPOIN)-SOM(ISOM,1)))
00078      &        INDIC(IPOIN) = 1
00079         ENDDO
00080 !
00081         IELEM = 1
00082 20      CONTINUE
00083         I1 = INDIC(IKLE(IELEM,1))
00084         I2 = INDIC(IKLE(IELEM,2))
00085         I3 = INDIC(IKLE(IELEM,3))
00086         IF (I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0) THEN
00087           IF (I1.EQ.1) INDIC(IKLE(IELEM,1)) = 2
00088           IF (I2.EQ.1) INDIC(IKLE(IELEM,2)) = 2
00089           IF (I3.EQ.1) INDIC(IKLE(IELEM,3)) = 2
00090           IKLE(IELEM,1) = IKLE(NELEM,1)
00091           IKLE(IELEM,2) = IKLE(NELEM,2)
00092           IKLE(IELEM,3) = IKLE(NELEM,3)
00093           NELEM = NELEM - 1
00094         ELSE
00095           IELEM = IELEM + 1
00096         ENDIF
00097         IF (IELEM.NE.NELEM+1) GOTO 20
00098 !
00099 !=======================================================================
00100 ! POUR UN DEMI PLAN DE COUPE DONNE :
00101 !      ELIMINATION DES ELEMENTS DEGENERES
00102 !=======================================================================
00103 !
00104 30      CONTINUE
00105         IELEM = 1
00106         FLAG = .FALSE.
00107 35      CONTINUE
00108         I1 = IKLE(IELEM,1)
00109         I2 = IKLE(IELEM,2)
00110         I3 = IKLE(IELEM,3)
00111         F1 = INDIC(I1).EQ.2
00112         F2 = INDIC(I2).EQ.2
00113         F3 = INDIC(I3).EQ.2
00114         IF (F1.AND.F2.AND.F3) THEN
00115           IKLE(IELEM,1) = IKLE(NELEM,1)
00116           IKLE(IELEM,2) = IKLE(NELEM,2)
00117           IKLE(IELEM,3) = IKLE(NELEM,3)
00118           NELEM = NELEM - 1
00119         ELSE
00120           IF (F1.AND.F2) THEN
00121             IF (DX*(X(I2)-X(I1))+DY*(Y(I2)-Y(I1)).LE.0.D0) THEN
00122               FLAG = .TRUE.
00123               INDIC(I3) = 2
00124             ENDIF
00125           ENDIF
00126           IF (F2.AND.F3) THEN
00127             IF (DX*(X(I3)-X(I2))+DY*(Y(I3)-Y(I2)).LE.0.D0) THEN
00128               FLAG = .TRUE.
00129               INDIC(I1) = 2
00130             ENDIF
00131           ENDIF
00132           IF (F3.AND.F1) THEN
00133             IF (DX*(X(I1)-X(I3))+DY*(Y(I1)-Y(I3)).LE.0.D0) THEN
00134               FLAG = .TRUE.
00135               INDIC(I2) = 2
00136             ENDIF
00137           ENDIF
00138           IELEM = IELEM + 1
00139         ENDIF
00140         IF (IELEM.NE.NELEM+1) GOTO 35
00141         IF (FLAG) GOTO 30
00142 !
00143 !=======================================================================
00144 ! POUR UN DEMI PLAN DE COUPE DONNE :
00145 !      PROJECTION DES NOUVEAUX POINTS DE BORD
00146 !=======================================================================
00147 !
00148         IF (PROJEC) THEN
00149           A1 = 1.D0 / (DX*DX + DY*DY)
00150           A2 = A1 * (SOM(ISOM,1)*SOM(ISOM+1,2) -
00151      &               SOM(ISOM,2)*SOM(ISOM+1,1) )
00152           DO IDP = 1,3
00153             DO IELEM = 1,NELEM
00154               IPOIN = IKLE(IELEM,IDP)
00155               IF (INDIC(IPOIN).EQ.2) THEN
00156                 A3 = A1*(X(IPOIN)*DX+Y(IPOIN)*DY)
00157                 X(IPOIN) = DX*A3 + DY*A2
00158                 Y(IPOIN) = DY*A3 - DX*A2
00159               ENDIF
00160             ENDDO
00161           ENDDO
00162         ENDIF
00163 !
00164       ENDDO !ISOM
00165 !
00166 !=======================================================================
00167 !
00168       RETURN
00169       END

Generated on Fri Aug 31 2013 18:12:58 by S.E.Bourban (HRW) using doxygen 1.7.0