proxim.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\utils\bief\proxim.f
00002 !
00075                      SUBROUTINE PROXIM
00076 !                    *****************
00077 !
00078      &(IP,XP,YP,X,Y,NP,NPOIN,IKLE,NELEM,NELMAX)
00079 !
00080 !***********************************************************************
00081 ! BIEF   V7P0                                   21/08/2010
00082 !***********************************************************************
00083 !
00084 !
00085 !
00086 !
00087 !
00088 !
00089 !
00090 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00091 !| IKLE           |-->| CONNECTIVITY TABLE.
00092 !| IP             |<--| ADDRESSES OF NEAREST POINTS
00093 !| NELEM          |-->| NUMBER OF ELEMENTS
00094 !| NELMAX         |-->| MAXIMUM NUMBER OF ELEMENTS
00095 !| NP             |-->| NUMBER OF POINTS IN THE SET
00096 !| NPOIN          |-->| NUMBER OF POINTS IN THE MESH
00097 !| X              |-->| ABSCISSAE OF POINTS IN THE MESH
00098 !| XP             |-->| ABSCISSAE OF POINTS IN THE SET
00099 !| Y              |-->| ORDINATES OF POINTS IN THE MESH
00100 !| YP             |-->| ORDINATES OF POINTS IN THE SET
00101 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00102 !
00103       USE BIEF, EX_PROXIM => PROXIM
00104 !
00105       IMPLICIT NONE
00106 !
00107       INTEGER LNG,LU
00108       COMMON/INFO/LNG,LU
00109 !
00110 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00111 !
00112       INTEGER, INTENT(IN)    :: NP,NPOIN,NELEM,NELMAX
00113       INTEGER, INTENT(INOUT) :: IP(NP)
00114       INTEGER, INTENT(IN)    :: IKLE(NELMAX,3)
00115 !
00116       DOUBLE PRECISION, INTENT(IN) :: XP(NP),YP(NP),X(NPOIN),Y(NPOIN)
00117 !
00118 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00119 !
00120       INTEGER I,K,IELEM
00121       DOUBLE PRECISION X1,Y1,X2,Y2,X3,Y3,A31,A12,A23,DIST2,D2,ALERT
00122       DOUBLE PRECISION XX,YY
00123 !
00124       INTRINSIC SQRT
00125 !
00126       DOUBLE PRECISION P_DSUM,P_DMAX
00127       EXTERNAL         P_DSUM,P_DMAX
00128 !
00129 !-----------------------------------------------------------------------
00130 !
00131       IF(NP.GT.0) THEN
00132       DO K=1,NP
00133         IP(K)=0
00134         DIST2=1.D10
00135         ALERT=0.D0
00136         XX=-1.D10
00137         YY=-1.D10
00138 !
00139 !       LOOP ON THE TRIANGLES:
00140 !
00141         DO IELEM=1,NELEM
00142           X1=X(IKLE(IELEM,1))
00143           X2=X(IKLE(IELEM,2))
00144           X3=X(IKLE(IELEM,3))
00145           Y1=Y(IKLE(IELEM,1))
00146           Y2=Y(IKLE(IELEM,2))
00147           Y3=Y(IKLE(IELEM,3))
00148           A31=XP(K)*Y3-YP(K)*X3+X3*Y1-X1*Y3+X1*YP(K)-XP(K)*Y1
00149           A12=XP(K)*Y1-YP(K)*X1+X1*Y2-X2*Y1+X2*YP(K)-XP(K)*Y2
00150           A23=XP(K)*Y2-YP(K)*X2+X2*Y3-X3*Y2+X3*YP(K)-XP(K)*Y3
00151           IF(A31.GT.-1.D-6.AND.A12.GT.-1.D-6.AND.A23.GT.-1.D-6) THEN
00152 !           TAKES THE NEAREST NODE
00153             DO I=1,3
00154               D2=(XP(K)-X(IKLE(IELEM,I)))**2+(YP(K)-Y(IKLE(IELEM,I)))**2
00155               IF(D2.LT.DIST2) THEN
00156                 IP(K)=IKLE(IELEM,I)
00157                 DIST2=D2
00158               ENDIF
00159             ENDDO
00160           ENDIF
00161         ENDDO ! IELEM
00162         IF(IP(K).EQ.0) THEN
00163           IF(LNG.EQ.1) THEN
00164             WRITE(LU,*) 'POINT SOURCE OU SPECTRE ',K,' HORS DOMAINE'
00165           ENDIF
00166           IF(LNG.EQ.2) THEN
00167             WRITE(LU,*) 'SPECTRUM OR SOURCE POINT ',K,' OUTSIDE DOMAIN'
00168           ENDIF
00169           IF(NCSIZE.LE.1) THEN
00170             WRITE(LU,*) ' '
00171             IF(LNG.EQ.1) WRITE(LU,*) 'INTERDIT EN MODE SCALAIRE'
00172             IF(LNG.EQ.2) WRITE(LU,*) 'NOT ALLOWED IN SCALAR MODE'
00173             CALL PLANTE(1)
00174             STOP
00175           ELSE
00176             IF(LNG.EQ.1) WRITE(LU,*) 'POSSIBLE EN MODE PARALLELE'
00177             IF(LNG.EQ.2) WRITE(LU,*) 'NOT A MISTAKE IN PARALLEL MODE'
00178           ENDIF
00179         ELSE
00180           IF(LNG.EQ.1) THEN
00181             WRITE(LU,*) 'POINT SOURCE ',K,' ASSIMILE AU POINT ',IP(K)
00182             WRITE(LU,*) 'SITUE A ',SQRT(DIST2),' METRES'
00183           ENDIF
00184           IF(LNG.EQ.2) THEN
00185             WRITE(LU,*) 'SOURCE POINT ',K,' PUT ON POINT ',IP(K)
00186             WRITE(LU,*) 'LOCATED AT ',SQRT(DIST2),' METRES'
00187           ENDIF
00188           IF(SQRT(DIST2).GT.1.D-8.AND.NCSIZE.GT.1) THEN
00189             XX=X(IP(K))
00190             YY=Y(IP(K))
00191             ALERT=1.D0
00192           ENDIF
00193         ENDIF
00194         IF(NCSIZE.GT.1) THEN
00195           XX=P_DMAX(XX)
00196           YY=P_DMAX(YY)
00197           ALERT=P_DSUM(ALERT)
00198         ENDIF
00199         IF(ALERT.GT.0.5D0) THEN
00200           WRITE(LU,*) ' '
00201           IF(LNG.EQ.1) THEN
00202             WRITE(LU,*) 'EN MODE PARALLELE LES SOURCES PONCTUELLES'
00203             WRITE(LU,*) 'OU LES POINTS DE SPECTRE (TOMAWAC)'
00204             WRITE(LU,*) 'DOIVENT COINCIDER EXACTEMENT AVEC DES POINTS'
00205             WRITE(LU,*) 'DU MAILLAGE, POUR LA SOURCE ',K,' CHOISIR :'
00206           ENDIF
00207           IF(LNG.EQ.2) THEN
00208             WRITE(LU,*) 'IN PARALLEL SOURCES OR SPECTRUM POINTS'
00209             WRITE(LU,*) 'MUST COINCIDE WITH'
00210             WRITE(LU,*) 'NODES IN THE MESH, FOR SOURCE',K,' CHOOSE:'
00211           ENDIF
00212           WRITE(LU,*) 'X=',XX,' Y=',YY
00213           CALL PLANTE(1)
00214           STOP
00215         ENDIF
00216       ENDDO
00217       ENDIF
00218 !
00219 !-----------------------------------------------------------------------
00220 !
00221       RETURN
00222       END

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