vc13pp.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\utils\bief\vc13pp.f
00002 !
00084                      SUBROUTINE VC13PP
00085 !                    *****************
00086 !
00087      &(XMUL,SF,F,X,Y,Z,SURFAC,
00088      & IKLE1,IKLE2,IKLE3,IKLE4,IKLE5,IKLE6,NELEM,NELMAX,
00089      & W1,W2,W3,W4,W5,W6,ICOORD,FORMUL)
00090 !
00091 !***********************************************************************
00092 ! BIEF   V6P3                                   21/08/2010
00093 !***********************************************************************
00094 !
00095 !
00096 !
00097 !
00098 !
00099 !
00100 !
00101 !
00102 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00103 !| F              |-->| FUNCTION USED IN THE VECTOR FORMULA
00104 !| FORMUL         |-->| SEE AT THE END OF THE SUBROUTINE
00105 !| ICOORD         |-->| 1: DERIVATIVE ALONG X, 2: ALONG Y
00106 !| IKLE1          |-->| FIRST POINT OF PRISMS
00107 !| IKLE2          |-->| SECOND POINT OF PRISMS
00108 !| IKLE3          |-->| THIRD POINT OF PRISMS
00109 !| IKLE4          |-->| FOURTH POINT OF PRISMS
00110 !| IKLE5          |-->| FIFTH POINT OF PRISMS
00111 !| IKLE6          |-->| SIXTH POINT OF PRISMS
00112 !| NELEM          |-->| NUMBER OF ELEMENTS
00113 !| NELMAX         |-->| MAXIMUM NUMBER OF ELEMENTS
00114 !| SF             |-->| BIEF_OBJ STRUCTURE OF F
00115 !| SURFAC         |-->| AREA OF TRIANGLES
00116 !| W1             |<--| RESULT IN NON ASSEMBLED FORM
00117 !| W2             |<--| RESULT IN NON ASSEMBLED FORM
00118 !| W3             |<--| RESULT IN NON ASSEMBLED FORM
00119 !| W4             |<--| RESULT IN NON ASSEMBLED FORM
00120 !| W5             |<--| RESULT IN NON ASSEMBLED FORM
00121 !| W6             |<--| RESULT IN NON ASSEMBLED FORM
00122 !| XEL            |-->| ABSCISSAE OF POINTS IN THE MESH, PER ELEMENT
00123 !| XMUL           |-->| MULTIPLICATION COEFFICIENT
00124 !| YEL            |-->| ORDINATES OF POINTS IN THE MESH, PER ELEMENT
00125 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00126 !
00127       USE BIEF, EX_VC13PP => VC13PP
00128 !
00129       IMPLICIT NONE
00130       INTEGER LNG,LU
00131       COMMON/INFO/LNG,LU
00132 !
00133 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00134 !
00135       INTEGER, INTENT(IN) :: NELEM,NELMAX,ICOORD
00136       INTEGER, INTENT(IN) :: IKLE1(NELMAX),IKLE2(NELMAX),IKLE3(NELMAX)
00137       INTEGER, INTENT(IN) :: IKLE4(NELMAX),IKLE5(NELMAX),IKLE6(NELMAX)
00138 !                                                               NPOIN
00139       DOUBLE PRECISION, INTENT(IN) :: X(NELMAX,6),Y(NELMAX,6),Z(*)
00140       DOUBLE PRECISION, INTENT(IN) :: SURFAC(NELMAX)
00141       DOUBLE PRECISION, INTENT(INOUT) ::W1(NELMAX),W2(NELMAX),W3(NELMAX)
00142       DOUBLE PRECISION, INTENT(INOUT) ::W4(NELMAX),W5(NELMAX),W6(NELMAX)
00143       DOUBLE PRECISION, INTENT(IN) :: XMUL
00144 !
00145 !     STRUCTURE OF F AND REAL DATA
00146 !
00147       TYPE(BIEF_OBJ), INTENT(IN) :: SF
00148       DOUBLE PRECISION, INTENT(IN) :: F(*)
00149       CHARACTER(LEN=16), INTENT(IN) :: FORMUL
00150 !
00151 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00152 !
00153       DOUBLE PRECISION XS24,XS144,F1,F2,F3,F4,F5,F6,XMU
00154       DOUBLE PRECISION X2,X3,Y2,Y3,Z1,Z2,Z3,Z4,Z5,Z6
00155       INTEGER I1,I2,I3,I4,I5,I6,IELEM,IELMF
00156 !
00157       INTRINSIC MAX,MIN
00158 !
00159 !-----------------------------------------------------------------------
00160 !
00161       XS24  = XMUL/24.D0
00162       XS144 = XMUL/144.D0
00163 !
00164 !-----------------------------------------------------------------------
00165 !
00166       IELMF=SF%ELM
00167 !
00168 !=======================================================================
00169 !
00170 !     F IS LINEAR
00171 !
00172       IF(IELMF.EQ.41) THEN
00173 !
00174       IF(ICOORD.EQ.1) THEN
00175 !
00176 !-----------------------------------------------------------------------
00177 !
00178 !  DERIVATIVE WRT X
00179 !
00180       DO IELEM = 1 , NELEM
00181 !
00182         I1 = IKLE1(IELEM)
00183         I2 = IKLE2(IELEM)
00184         I3 = IKLE3(IELEM)
00185         I4 = IKLE4(IELEM)
00186         I5 = IKLE5(IELEM)
00187         I6 = IKLE6(IELEM)
00188 !
00189         F1 = F(I1)
00190         F2 = F(I2)
00191         F3 = F(I3)
00192         F4 = F(I4)
00193         F5 = F(I5)
00194         F6 = F(I6)
00195 !
00196 !  REAL COORDINATES OF THE POINTS OF THE ELEMENT (ORIGIN IN 1)
00197 !
00198 !       Y2  =  Y(I2) - Y(I1)
00199 !       Y3  =  Y(I3) - Y(I1)
00200         Y2  =  Y(IELEM,2)
00201         Y3  =  Y(IELEM,3)
00202 !
00203         Z2  =  Z(I2) - Z(I1)
00204         Z3  =  Z(I3) - Z(I1)
00205         Z4  =  Z(I4) - Z(I1)
00206         Z5  =  Z(I5) - Z(I1)
00207         Z6  =  Z(I6) - Z(I1)
00208 !
00209       W1(IELEM)=( (2*F1-F6)*Y2*( Z5+3*Z4-3*Z3  -Z2)
00210      &           +(2*F1-F5)*Y3*(-Z6-3*Z4  +Z3+3*Z2)
00211      &                  +F2*Y3*(2*Z6+3*Z5+3*Z4-2*Z3)
00212      &                  +F3*Y2*(-3*Z6-2*Z5-3*Z4+2*Z2)
00213      &             +(F3-F6)*Y3*(Z5-Z4+2*Z2)
00214      &                  +F4*Y2*(3*Z6+Z5+3*Z3-Z2)
00215      &                  +F4*Y3*(-Z6-3*Z5+Z3-3*Z2)
00216      &             +(F5-F2)*Y2*(Z6-Z4+2*Z3) )*XS144
00217       W2(IELEM)=(   F1*Y2*(Z6+4*Z5+3*Z4-4*Z3-4*Z2)
00218      &             +F1*Y3*(-2*Z6-3*Z5-3*Z4+2*Z3+6*Z2)
00219      &      +(2*F2-F4)*Y3*(Z6+3*Z5-Z3)
00220      &             +F3*Y2*(-3*Z6-4*Z5-Z4+4*Z2)
00221      &             +F4*Y2*(2*Z6+2*Z5+Z3-2*Z2)
00222      &      +2*(F5-F2)*Y2*(Z6-Z4+2*Z3)
00223      &             +F5*Y3*(Z6+3*Z4-Z3-6*Z2)
00224      &             +F6*Y2*(-2*Z5-2*Z4+3*Z3+2*Z2)
00225      &        +(F6-F3)*Y3*(-Z5+Z4-2*Z2) )*XS144
00226       W3(IELEM)=(   F1*Y2*(3*Z6+2*Z5+3*Z4-6*Z3-2*Z2)
00227      &             +F1*Y3*(-4*Z6-Z5-3*Z4+4*Z3+4*Z2)
00228      &             +F2*Y3*(4*Z6+3*Z5+Z4-4*Z3)
00229      &      +(2*F3-F4)*Y2*(-3*Z6-Z5+Z2)
00230      &             +F4*Y3*(-2*Z6-2*Z5+2*Z3-Z2)
00231      &        +(F5-F2)*Y2*(Z6-Z4+2*Z3)
00232      &             +F5*Y3*(2*Z6+2*Z4-2*Z3-3*Z2)
00233      &             +F6*Y2*(-Z5-3*Z4+6*Z3+Z2)
00234      &      +2*(F6-F3)*Y3*(-Z5+Z4-2*Z2) )*XS144
00235       W4(IELEM)=(   F1*Y2*(-3*Z6+Z5+6*Z4-3*Z3-Z2)
00236      &             +F1*Y3*(-Z6+3*Z5-6*Z4+Z3+3*Z2)
00237      &             +F2*Y3*(Z6+3*Z5-Z3)
00238      &      +(2*F4-F3)*Y2*(3*Z6+Z5-Z2)
00239      &           +2*F4*Y3*(-Z6-3*Z5+Z3)
00240      &        +(F5-F2)*Y2*(2*Z6-2*Z4+Z3)
00241      &             +F5*Y3*(2*Z6+6*Z4-2*Z3-3*Z2)
00242      &             +F6*Y2*(-2*Z5-6*Z4+3*Z3+2*Z2)
00243      &        +(F6-F3)*Y3*(-2*Z5+2*Z4-Z2)  )*XS144
00244       W5(IELEM)=(   F1*Y2*(-Z6+2*Z5+3*Z4-2*Z3-2*Z2)
00245      &             +F2*Y3*(Z6+6*Z5-3*Z4-Z3)
00246      &             +F3*Y2*(-3*Z6-2*Z5+Z4+2*Z2)
00247      &             +F4*Y2*(4*Z6+4*Z5-Z3-4*Z2)
00248      &             +F4*Y3*(-2*Z6-6*Z5+2*Z3+3*Z2)
00249      &      +2*(F5-F2)*Y2*(2*Z6-2*Z4+Z3)
00250      &      +(2*F5-F1)*Y3*(Z6+3*Z4-Z3-3*Z2)
00251      &             +F6*Y2*(-4*Z5-4*Z4+3*Z3+4*Z2)
00252      &        +(F6-F3)*Y3*(-2*Z5+2*Z4-Z2) )*XS144
00253       W6(IELEM)=(  +F1*Y3*(-2*Z6+Z5-3*Z4+2*Z3+2*Z2)
00254      &             +F2*Y3*(2*Z6+3*Z5-Z4-2*Z3)
00255      &             +F3*Y2*(-6*Z6-Z5+3*Z4+Z2)
00256      &             +F4*Y2*(6*Z6+2*Z5-3*Z3-2*Z2)
00257      &             +F4*Y3*(-4*Z6-4*Z5+4*Z3+Z2)
00258      &        +(F5-F2)*Y2*(2*Z6-2*Z4+Z3)
00259      &             +F5*Y3*(4*Z6+4*Z4-4*Z3-3*Z2)
00260      &      +(2*F6-F1)*Y2*(-Z5-3*Z4+3*Z3+Z2)
00261      &      +2*(F6-F3)*Y3*(-2*Z5+2*Z4-Z2) )*XS144
00262 !
00263       ENDDO ! IELEM
00264 !
00265       ELSEIF(ICOORD.EQ.2) THEN
00266 !
00267 !-----------------------------------------------------------------------
00268 !
00269 !  DERIVATIVE WRT Y
00270 !
00271       DO IELEM = 1 , NELEM
00272 !
00273         I1 = IKLE1(IELEM)
00274         I2 = IKLE2(IELEM)
00275         I3 = IKLE3(IELEM)
00276         I4 = IKLE4(IELEM)
00277         I5 = IKLE5(IELEM)
00278         I6 = IKLE6(IELEM)
00279 !
00280         F1 = F(I1)
00281         F2 = F(I2)
00282         F3 = F(I3)
00283         F4 = F(I4)
00284         F5 = F(I5)
00285         F6 = F(I6)
00286 !
00287 !  REAL COORDINATES OF THE POINTS OF THE ELEMENT (ORIGIN IN 1)
00288 !
00289 !       X2  =  X(I2) - X(I1)
00290 !       X3  =  X(I3) - X(I1)
00291         X2  =  X(IELEM,2)
00292         X3  =  X(IELEM,3)
00293 !
00294         Z2  =  Z(I2) - Z(I1)
00295         Z3  =  Z(I3) - Z(I1)
00296         Z4  =  Z(I4) - Z(I1)
00297         Z5  =  Z(I5) - Z(I1)
00298         Z6  =  Z(I6) - Z(I1)
00299 !
00300       W1(IELEM)=( (2*F1-F6)*X2*(-Z5-3*Z4+3*Z3+Z2)
00301      &                +2*F1*X3*(Z6+3*Z4-Z3-3*Z2)
00302      &                  +F2*X3*(-2*Z6-3*Z5-3*Z4+2*Z3)
00303      &                  +F3*X2*(3*Z6+2*Z5+3*Z4-2*Z2)
00304      &                  +F4*X2*(-3*Z6-Z5-3*Z3+Z2)
00305      &                  +F4*X3*(Z6+3*Z5-Z3+3*Z2)
00306      &             +(F5-F2)*X2*(-Z6+Z4-2*Z3)
00307      &                  +F5*X3*(-Z6-3*Z4+Z3+3*Z2)
00308      &             +(F6-F3)*X3*(Z5-Z4+2*Z2) )*XS144
00309       W2(IELEM)=( F1*X2*(-Z6-4*Z5-3*Z4+4*Z3+4*Z2)
00310      &           +F1*X3*(2*Z6+3*Z5+3*Z4-2*Z3-6*Z2)
00311      &    +(2*F2-F4)*X3*(-Z6-3*Z5+Z3)
00312      &           +F3*X2*(3*Z6+4*Z5+Z4-4*Z2)
00313      &           +F4*X2*(-2*Z6-2*Z5-Z3+2*Z2)
00314      &    +2*(F5-F2)*X2*(-Z6+Z4-2*Z3)
00315      &           +F5*X3*(-Z6-3*Z4+Z3+6*Z2)
00316      &           +F6*X2*(2*Z5+2*Z4-3*Z3-2*Z2)
00317      &      +(F6-F3)*X3*(Z5-Z4+2*Z2) )*XS144
00318       W3(IELEM)=( F1*X2*(-3*Z6-2*Z5-3*Z4+6*Z3+2*Z2)
00319      &           +F1*X3*(4*Z6+Z5+3*Z4-4*Z3-4*Z2)
00320      &           +F2*X3*(-4*Z6-3*Z5-Z4+4*Z3)
00321      &    +(2*F3-F4)*X2*(3*Z6+Z5-Z2)
00322      &           +F4*X3*(2*Z6+2*Z5-2*Z3+Z2)
00323      &      +(F5-F2)*X2*(-Z6+Z4-2*Z3)
00324      &           +F5*X3*(-2*Z6-2*Z4+2*Z3+3*Z2)
00325      &           +F6*X2*(Z5+3*Z4-6*Z3-Z2)
00326      &    +2*(F6-F3)*X3*(Z5-Z4+2*Z2) )*XS144
00327       W4(IELEM)=( F1*X2*(3*Z6-Z5-6*Z4+3*Z3+Z2)
00328      &           +F1*X3*(Z6-3*Z5+6*Z4-Z3-3*Z2)
00329      &    +(2*F4-F3)*X2*(-3*Z6-Z5+Z2)
00330      &    +(2*F4-F2)*X3*(Z6+3*Z5-Z3)
00331      &      +(F5-F2)*X2*(-2*Z6+2*Z4-Z3)
00332      &           +F5*X3*(-2*Z6-6*Z4+2*Z3+3*Z2)
00333      &           +F6*X2*(2*Z5+6*Z4-3*Z3-2*Z2)
00334      &      +(F6-F3)*X3*(2*Z5-2*Z4+Z2) )*XS144
00335       W5(IELEM)=( F1*X2*(Z6-2*Z5-3*Z4+2*Z3+2*Z2)
00336      &           +F2*X3*(-Z6-6*Z5+3*Z4+Z3)
00337      &           +F3*X2*(3*Z6+2*Z5-Z4-2*Z2)
00338      &           +F4*X2*(-4*Z6-4*Z5+Z3+4*Z2)
00339      &           +F4*X3*(2*Z6+6*Z5-2*Z3-3*Z2)
00340      &    +2*(F5-F2)*X2*(-2*Z6+2*Z4-Z3)
00341      &    +(2*F5-F1)*X3*(-Z6-3*Z4+Z3+3*Z2)
00342      &           +F6*X2*(4*Z5+4*Z4-3*Z3-4*Z2)
00343      &      +(F6-F3)*X3*(2*Z5-2*Z4+Z2)  )*XS144
00344       W6(IELEM)=(+F1*X3*(2*Z6-Z5+3*Z4-2*Z3-2*Z2)
00345      &           +F2*X3*(-2*Z6-3*Z5+Z4+2*Z3)
00346      &           +F3*X2*(6*Z6+Z5-3*Z4-Z2)
00347      &           +F4*X2*(-6*Z6-2*Z5+3*Z3+2*Z2)
00348      &           +F4*X3*(4*Z6+4*Z5-4*Z3-Z2)
00349      &      +(F5-F2)*X2*(-2*Z6+2*Z4-Z3)
00350      &           +F5*X3*(-4*Z6-4*Z4+4*Z3+3*Z2)
00351      &    +(2*F6-F1)*X2*(Z5+3*Z4-3*Z3-Z2)
00352      &    +2*(F6-F3)*X3*(2*Z5-2*Z4+Z2)  )*XS144
00353 !
00354 !
00355         ENDDO ! IELEM
00356 !
00357       ELSEIF(ICOORD.EQ.3) THEN
00358 !
00359 !-----------------------------------------------------------------------
00360 !
00361 !  DERIVATIVE WRT Z
00362 !
00363       DO IELEM = 1 , NELEM
00364 !
00365         I1 = IKLE1(IELEM)
00366         I2 = IKLE2(IELEM)
00367         I3 = IKLE3(IELEM)
00368         I4 = IKLE4(IELEM)
00369         I5 = IKLE5(IELEM)
00370         I6 = IKLE6(IELEM)
00371 !
00372         F1 = F(I1)
00373         F2 = F(I2)
00374         F3 = F(I3)
00375         F4 = F(I4)
00376         F5 = F(I5)
00377         F6 = F(I6)
00378 !
00379 !  REAL COORDINATES OF THE POINTS OF THE ELEMENT (ORIGIN IN 1)
00380 !
00381 !       X2  =  X(I2) - X(I1)
00382 !       X3  =  X(I3) - X(I1)
00383 !       Y2  =  Y(I2) - Y(I1)
00384 !       Y3  =  Y(I3) - Y(I1)
00385 !
00386 !       XMU  = XS48*(X2*Y3-X3*Y2)
00387         XMU  = XS24*SURFAC(IELEM)
00388 !
00389 !       NOT LUMPED VERSION
00390 !       DIFF = (F4+F5+F6) - (F1+F2+F3)
00391 !       W1(IELEM)=(F4-F1+DIFF)*XMU
00392 !       W2(IELEM)=(F5-F2+DIFF)*XMU
00393 !       W3(IELEM)=(F6-F3+DIFF)*XMU
00394 !       LUMPED VERSION (LIKE THE DIFFUSION MATRIX)
00395 !       SEE W COMPUTATION IN TELEMAC-3D IN PROVEL
00396         W1(IELEM)=4*(F4-F1)*XMU
00397         W2(IELEM)=4*(F5-F2)*XMU
00398         W3(IELEM)=4*(F6-F3)*XMU
00399 !
00400         W4(IELEM)=W1(IELEM)
00401         W5(IELEM)=W2(IELEM)
00402         W6(IELEM)=W3(IELEM)
00403 !
00404       ENDDO ! IELEM
00405 !
00406       ELSE
00407 !
00408 !-----------------------------------------------------------------------
00409 !
00410         IF (LNG.EQ.1) WRITE(LU,200) ICOORD
00411         IF (LNG.EQ.2) WRITE(LU,201) ICOORD
00412 200     FORMAT(1X,'VC13PP (BIEF) : COMPOSANTE IMPOSSIBLE ',
00413      &            1I6,' VERIFIER ICOORD')
00414 201     FORMAT(1X,'VC13PP (BIEF) : IMPOSSIBLE COMPONENT ',
00415      &            1I6,' CHECK ICOORD')
00416         CALL PLANTE(1)
00417         STOP
00418 !
00419       ENDIF
00420 !
00421 !=======================================================================
00422 !
00423       ELSE
00424 !
00425 !=======================================================================
00426 !
00427         IF (LNG.EQ.1) WRITE(LU,101) IELMF,SF%NAME
00428         IF (LNG.EQ.2) WRITE(LU,102) IELMF,SF%NAME
00429 101     FORMAT(1X,'VC13PP (BIEF) :',/,
00430      &         1X,'DISCRETISATION DE F : ',1I6,' CAS NON PREVU',/,
00431      &         1X,'NOM REEL DE F : ',A6)
00432 102     FORMAT(1X,'VC13PP (BIEF) :',/,
00433      &         1X,'DISCRETISATION OF F : ',1I6,' NOT IMPLEMENTED',/,
00434      &         1X,'REAL NAME OF F: ',A6)
00435         CALL PLANTE(1)
00436         STOP
00437 !
00438       ENDIF
00439 !
00440 !=======================================================================
00441 !
00442 !     HYDROSTATIC INCONSISTENCIES
00443 !
00444 !     COMMON TREATMENT FOR FILTERS 2,3 AND 4
00445 !
00446       IF(FORMUL(6:6).EQ.'2'.OR.FORMUL(6:6).EQ.'3'.OR.
00447      &   FORMUL(6:6).EQ.'4'     ) THEN
00448 !
00449         DO IELEM = 1 , NELEM
00450 !
00451           I1 = IKLE1(IELEM)
00452           I2 = IKLE2(IELEM)
00453           I3 = IKLE3(IELEM)
00454           I4 = IKLE4(IELEM)
00455           I5 = IKLE5(IELEM)
00456           I6 = IKLE6(IELEM)
00457 !
00458           IF(MAX(Z(I1),Z(I2),Z(I3)).GT.MIN(Z(I4),Z(I5),Z(I6))) THEN
00459             W1(IELEM)=0.D0
00460             W2(IELEM)=0.D0
00461             W3(IELEM)=0.D0
00462             W4(IELEM)=0.D0
00463             W5(IELEM)=0.D0
00464             W6(IELEM)=0.D0
00465           ENDIF
00466 !
00467         ENDDO
00468 !
00469       ENDIF
00470 !
00471 !     FILTER 3
00472 !
00473       IF(FORMUL(6:6).EQ.'3'.AND.(ICOORD.EQ.1.OR.ICOORD.EQ.2)) THEN
00474 !
00475         DO IELEM = 1 , NELEM
00476 !
00477           I1 = IKLE1(IELEM)
00478           I2 = IKLE2(IELEM)
00479           I3 = IKLE3(IELEM)
00480           I4 = IKLE4(IELEM)
00481           I5 = IKLE5(IELEM)
00482           I6 = IKLE6(IELEM)
00483 !
00484           F1 = F(I1)
00485           F2 = F(I2)
00486           F3 = F(I3)
00487           F4 = F(I4)
00488           F5 = F(I5)
00489           F6 = F(I6)
00490 !
00491 !         IF THERE IS A POSSIBILITY OF STRATIFICATION
00492 !         GRADIENTS CANCELLED
00493 !
00494           IF( MIN(MAX(F1,F4),MAX(F2,F5),MAX(F3,F6)).GE.
00495      &        MAX(MIN(F1,F4),MIN(F2,F5),MIN(F3,F6))     ) THEN
00496             W1(IELEM)=0.D0
00497             W2(IELEM)=0.D0
00498             W3(IELEM)=0.D0
00499             W4(IELEM)=0.D0
00500             W5(IELEM)=0.D0
00501             W6(IELEM)=0.D0
00502           ENDIF
00503 !
00504         ENDDO
00505 !
00506       ENDIF
00507 !
00508 !     FILTER 4
00509 !
00510       IF(FORMUL(6:6).EQ.'4'.AND.(ICOORD.EQ.1.OR.ICOORD.EQ.2)) THEN
00511 !
00512         DO IELEM = 1 , NELEM
00513 !
00514           I1 = IKLE1(IELEM)
00515           I2 = IKLE2(IELEM)
00516           I3 = IKLE3(IELEM)
00517           I4 = IKLE4(IELEM)
00518           I5 = IKLE5(IELEM)
00519           I6 = IKLE6(IELEM)
00520 !
00521           F1 = F(I1)
00522           F2 = F(I2)
00523           F3 = F(I3)
00524           F4 = F(I4)
00525           F5 = F(I5)
00526           F6 = F(I6)
00527 !
00528           Z1 = Z(I1)
00529           Z2 = Z(I2)
00530           Z3 = Z(I3)
00531           Z4 = Z(I4)
00532           Z5 = Z(I5)
00533           Z6 = Z(I6)
00534 !
00535 !         CHECKS IF A STRATIFICATION IS IMPOSSIBLE
00536 !         IN THIS CASE (GO TO 1000) GRADIENTS ARE KEPT
00537 !
00538 !         1 IN BETWEEN 3 AND 6
00539           IF(Z1.GE.Z3.AND.Z1.LE.Z6) THEN
00540             IF(F1.LT.MIN(F3,F6).OR.F1.GT.MAX(F3,F6)) GO TO 1000
00541           ENDIF
00542 !         1 IN BETWEEN 2 AND 5
00543           IF(Z1.GE.Z2.AND.Z1.LE.Z5) THEN
00544             IF(F1.LT.MIN(F2,F5).OR.F1.GT.MAX(F2,F5)) GO TO 1000
00545           ENDIF
00546 !         2 IN BETWEEN 1 AND 4
00547           IF(Z2.GE.Z1.AND.Z2.LE.Z4) THEN
00548             IF(F2.LT.MIN(F1,F4).OR.F2.GT.MAX(F1,F4)) GO TO 1000
00549           ENDIF
00550 !         2 IN BETWEEN 3 AND 6
00551           IF(Z2.GE.Z3.AND.Z2.LE.Z6) THEN
00552             IF(F2.LT.MIN(F3,F6).OR.F2.GT.MAX(F3,F6)) GO TO 1000
00553           ENDIF
00554 !         3 IN BETWEEN 1 AND 4
00555           IF(Z3.GE.Z1.AND.Z3.LE.Z4) THEN
00556             IF(F3.LT.MIN(F1,F4).OR.F3.GT.MAX(F1,F4)) GO TO 1000
00557           ENDIF
00558 !         3 IN BETWEEN 2 AND 5
00559           IF(Z3.GE.Z2.AND.Z3.LE.Z5) THEN
00560             IF(F3.LT.MIN(F2,F5).OR.F3.GT.MAX(F2,F5)) GO TO 1000
00561           ENDIF
00562 !         4 IN BETWEEN 2 AND 5
00563           IF(Z4.GE.Z2.AND.Z4.LE.Z5) THEN
00564             IF(F4.LT.MIN(F2,F5).OR.F4.GT.MAX(F2,F5)) GO TO 1000
00565           ENDIF
00566 !         4 IN BETWEEN 3 AND 6
00567           IF(Z4.GE.Z3.AND.Z4.LE.Z6) THEN
00568             IF(F4.LT.MIN(F3,F6).OR.F4.GT.MAX(F3,F6)) GO TO 1000
00569           ENDIF
00570 !         5 IN BETWEEN 1 AND 4
00571           IF(Z5.GE.Z1.AND.Z5.LE.Z4) THEN
00572             IF(F5.LT.MIN(F1,F4).OR.F5.GT.MAX(F1,F4)) GO TO 1000
00573           ENDIF
00574 !         5 IN BETWEEN 3 AND 6
00575           IF(Z5.GE.Z3.AND.Z5.LE.Z6) THEN
00576             IF(F5.LT.MIN(F3,F6).OR.F5.GT.MAX(F3,F6)) GO TO 1000
00577           ENDIF
00578 !         6 IN BETWEEN 1 AND 4
00579           IF(Z6.GE.Z1.AND.Z6.LE.Z4) THEN
00580             IF(F6.LT.MIN(F1,F4).OR.F6.GT.MAX(F1,F4)) GO TO 1000
00581           ENDIF
00582 !         6 IN BETWEEN 2 AND 5
00583           IF(Z6.GE.Z2.AND.Z6.LE.Z5) THEN
00584             IF(F6.LT.MIN(F2,F5).OR.F6.GT.MAX(F2,F5)) GO TO 1000
00585           ENDIF
00586 !
00587 !         SO THERE IS A POSSIBILITY OF STRATIFICATION
00588 !         GRADIENTS CANCELLED
00589 !
00590           W1(IELEM)=0.D0
00591           W2(IELEM)=0.D0
00592           W3(IELEM)=0.D0
00593           W4(IELEM)=0.D0
00594           W5(IELEM)=0.D0
00595           W6(IELEM)=0.D0
00596 !
00597 1000      CONTINUE
00598 !
00599         ENDDO
00600 !
00601       ENDIF
00602 !
00603 !     FILTER FOR PARTLY CRUSHED PRISMS
00604 !
00605       IF(FORMUL(7:7).EQ.'2') THEN
00606 !
00607         DO IELEM = 1 , NELEM
00608           I1 = IKLE1(IELEM)
00609           I2 = IKLE2(IELEM)
00610           I3 = IKLE3(IELEM)
00611           I4 = IKLE4(IELEM)
00612           I5 = IKLE5(IELEM)
00613           I6 = IKLE6(IELEM)
00614           IF(Z(I4)-Z(I1).LT.1.D-3.OR.
00615      &       Z(I5)-Z(I2).LT.1.D-3.OR.
00616      &       Z(I6)-Z(I3).LT.1.D-3     ) THEN
00617             W1(IELEM)=0.D0
00618             W2(IELEM)=0.D0
00619             W3(IELEM)=0.D0
00620             W4(IELEM)=0.D0
00621             W5(IELEM)=0.D0
00622             W6(IELEM)=0.D0
00623           ENDIF
00624         ENDDO
00625 !
00626       ENDIF
00627 !
00628 !=======================================================================
00629 !
00630       RETURN
00631       END

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