friction_quad.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\telemac2d\friction_quad.f
00002 !
00054                      SUBROUTINE FRICTION_QUAD
00055 !                    ************************
00056 !
00057      &(IKLE, NPOIN, NELEM, NELMAX, LINDNER, NKFROT, CHESTR, NDEFMA,
00058      & LINDDP, LINDSP)
00059 !
00060 !***********************************************************************
00061 ! TELEMAC2D   V6P1                                   21/08/2010
00062 !***********************************************************************
00063 !
00064 !
00065 !
00066 !
00067 !
00068 !
00069 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00070 !| CHESTR         |<->| FRICTION COEFFICIENTS
00071 !| IKLE           |-->| CONNECTIVITY TABLE.
00072 !| LINDDP         |<--| DIAMETER OF ROUGHNESS ELEMENT IN LINDNER CASE
00073 !| LINDNER        |-->| IF YES, THERE IS NON-SUBMERGED VEGETATION FRICTION
00074 !| LINDSP         |<--| SPACING OF ROUGHNESS ELEMENT IN LINDNER CASE
00075 !| NDEFMA         |<--| DEFAULT MANNING COEFFICIENT
00076 !| NELEM          |-->| NUMBER OF ELEMENTS
00077 !| NELMAX         |-->| MAXIMUM NUMBER OF ELEMENTS
00078 !| NKFROT         |<->| LAW OF BOTTOM FRICTION FOR EVERY POINT
00079 !| NPOIN          |-->| NUMBER OF POINTS
00080 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00081 !
00082       USE BIEF
00083       IMPLICIT NONE
00084       INTEGER LNG,LU
00085       COMMON/INFO/LNG,LU
00086 !
00087 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00088 !
00089       INTEGER,        INTENT(IN)    :: NPOIN,NELEM,NELMAX
00090       INTEGER,        INTENT(IN)    :: IKLE(NELMAX,6)
00091       LOGICAL,        INTENT(IN)    :: LINDNER
00092       TYPE(BIEF_OBJ), INTENT(INOUT) :: NKFROT,CHESTR,NDEFMA
00093       TYPE(BIEF_OBJ), INTENT(INOUT) :: LINDDP,LINDSP
00094 !
00095 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00096 !
00097       INTEGER :: IELEM
00098 !
00099 !=======================================================================!
00100 !=======================================================================!
00101 !                               PROGRAMME                               !
00102 !=======================================================================!
00103 !=======================================================================!
00104 !
00105 ! IF THE 11 NODES HAVE THE SAME FRICTION LAW, INTERPOLATION A LA CG1113
00106 ! FOR THE VALUES AT 13 ADDITIONAL NODES IN THE MIDDLE OF THE EDGES
00107 !
00108 !        X(IKLE(IELEM,4)) = 0.5D0 * ( X(IKLE(IELEM,1))
00109 !     &                             + X(IKLE(IELEM,2)) )
00110 !        X(IKLE(IELEM,5)) = 0.5D0 * ( X(IKLE(IELEM,2))
00111 !     &                             + X(IKLE(IELEM,3)) )
00112 !        X(IKLE(IELEM,6)) = 0.5D0 * ( X(IKLE(IELEM,3))
00113 !     &                             + X(IKLE(IELEM,1)) )
00114 !
00115 ! WELL, IF THE THE FRICTION LAWS DIFFER, TAKE THE VALUE ON THE PREVIOUS
00116 ! NODE BY CIRCUMVENTING THE ELEMENT...
00117 !
00118 !        X(IKLE(IELEM,4)) = X(IKLE(IELEM,1))
00119 !        X(IKLE(IELEM,5)) = X(IKLE(IELEM,2))
00120 !        X(IKLE(IELEM,6)) = X(IKLE(IELEM,3))
00121 !
00122 ! ASSUMED THE TRIVIAL CASE OF -ONE- ZONE ONLY IS NATURALLY EXCLUDED
00123 !
00124       DO IELEM = 1,NELEM
00125         IF(NKFROT%I(IKLE(IELEM,1)).EQ.NKFROT%I(IKLE(IELEM,2))) THEN
00126           NKFROT%I(IKLE(IELEM,4)) = NKFROT%I(IKLE(IELEM,1))
00127           CHESTR%R(IKLE(IELEM,4)) =
00128      &      0.5D0*(CHESTR%R(IKLE(IELEM,1))+CHESTR%R(IKLE(IELEM,2)))
00129           NDEFMA%R(IKLE(IELEM,4)) =
00130      &      0.5D0*(NDEFMA%R(IKLE(IELEM,1))+NDEFMA%R(IKLE(IELEM,2)))
00131         ELSE
00132           NKFROT%I(IKLE(IELEM,4)) = NKFROT%I(IKLE(IELEM,1))
00133           CHESTR%R(IKLE(IELEM,4)) = CHESTR%R(IKLE(IELEM,1))
00134           NDEFMA%R(IKLE(IELEM,4)) = NDEFMA%R(IKLE(IELEM,1))
00135         ENDIF
00136         IF(NKFROT%I(IKLE(IELEM,2)).EQ.NKFROT%I(IKLE(IELEM,3))) THEN
00137           NKFROT%I(IKLE(IELEM,5)) = NKFROT%I(IKLE(IELEM,2))
00138           CHESTR%R(IKLE(IELEM,5)) =
00139      &      0.5D0*(CHESTR%R(IKLE(IELEM,2))+CHESTR%R(IKLE(IELEM,3)))
00140           NDEFMA%R(IKLE(IELEM,5)) =
00141      &      0.5D0*(NDEFMA%R(IKLE(IELEM,2))+NDEFMA%R(IKLE(IELEM,3)))
00142         ELSE
00143           NKFROT%I(IKLE(IELEM,5)) = NKFROT%I(IKLE(IELEM,2))
00144           CHESTR%R(IKLE(IELEM,5)) = CHESTR%R(IKLE(IELEM,2))
00145           NDEFMA%R(IKLE(IELEM,5)) = NDEFMA%R(IKLE(IELEM,2))
00146         ENDIF
00147         IF(NKFROT%I(IKLE(IELEM,3)).EQ.NKFROT%I(IKLE(IELEM,1))) THEN
00148           NKFROT%I(IKLE(IELEM,6)) = NKFROT%I(IKLE(IELEM,3))
00149           CHESTR%R(IKLE(IELEM,6)) =
00150      &      0.5D0*(CHESTR%R(IKLE(IELEM,3))+CHESTR%R(IKLE(IELEM,1)))
00151           NDEFMA%R(IKLE(IELEM,6)) =
00152      &      0.5D0*(NDEFMA%R(IKLE(IELEM,3))+NDEFMA%R(IKLE(IELEM,1)))
00153         ELSE
00154           NKFROT%I(IKLE(IELEM,6)) = NKFROT%I(IKLE(IELEM,3))
00155           CHESTR%R(IKLE(IELEM,6)) = CHESTR%R(IKLE(IELEM,3))
00156           NDEFMA%R(IKLE(IELEM,6)) = NDEFMA%R(IKLE(IELEM,3))
00157         ENDIF
00158       ENDDO
00159       ! THIS RARE CASE SEPARATELY
00160       IF (LINDNER) THEN
00161         DO IELEM = 1,NELEM
00162           IF (NKFROT%I(IKLE(IELEM,1)).EQ.NKFROT%I(IKLE(IELEM,2))) THEN
00163             LINDDP%R(IKLE(IELEM,4)) =
00164      &        0.5D0*(LINDDP%R(IKLE(IELEM,1))+LINDDP%R(IKLE(IELEM,2)))
00165             LINDSP%R(IKLE(IELEM,4)) =
00166      &        0.5D0*(LINDSP%I(IKLE(IELEM,1))+LINDSP%R(IKLE(IELEM,2)))
00167           ELSE
00168             LINDDP%R(IKLE(IELEM,4)) = LINDDP%R(IKLE(IELEM,1))
00169             LINDSP%R(IKLE(IELEM,4)) = LINDSP%R(IKLE(IELEM,1))
00170           ENDIF
00171           IF (NKFROT%I(IKLE(IELEM,2)).EQ.NKFROT%I(IKLE(IELEM,3))) THEN
00172             LINDDP%R(IKLE(IELEM,5)) =
00173      &        0.5D0*(LINDDP%R(IKLE(IELEM,2))+LINDDP%R(IKLE(IELEM,3)))
00174             LINDSP%R(IKLE(IELEM,5)) =
00175      &        0.5D0*(LINDSP%I(IKLE(IELEM,2))+LINDSP%R(IKLE(IELEM,3)))
00176           ELSE
00177             LINDDP%R(IKLE(IELEM,5)) = LINDDP%R(IKLE(IELEM,2))
00178             LINDSP%R(IKLE(IELEM,5)) = LINDSP%R(IKLE(IELEM,2))
00179           ENDIF
00180           IF (NKFROT%I(IKLE(IELEM,3)).EQ.NKFROT%I(IKLE(IELEM,1))) THEN
00181             LINDDP%R(IKLE(IELEM,6)) =
00182      &        0.5D0*(LINDDP%R(IKLE(IELEM,3))+LINDDP%R(IKLE(IELEM,1)))
00183             LINDSP%R(IKLE(IELEM,6)) =
00184      &        0.5D0*(LINDSP%I(IKLE(IELEM,3))+LINDSP%R(IKLE(IELEM,1)))
00185           ELSE
00186             LINDDP%R(IKLE(IELEM,6)) = LINDDP%R(IKLE(IELEM,3))
00187             LINDSP%R(IKLE(IELEM,6)) = LINDSP%R(IKLE(IELEM,3))
00188           ENDIF
00189         ENDDO
00190       ENDIF
00191 !
00192 !=======================================================================!
00193 !=======================================================================!
00194 !
00195       RETURN
00196       END SUBROUTINE FRICTION_QUAD

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