crsl12.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\utils\bief\crsl12.f
00002 !
00049                      SUBROUTINE CRSL12
00050 !                    *****************
00051 !
00052      &(NEWSL,OLDSL,ZF,IKLE,NELEM,NELMAX)
00053 !
00054 !***********************************************************************
00055 ! BIEF   V6P1                                   21/08/2010
00056 !***********************************************************************
00057 !
00058 !
00059 !
00060 !
00061 !
00062 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00063 !| IKLE           |-->| CONNECTIVITY TABLE
00064 !| NELEM          |-->| NUMBER OF ELEMENTS
00065 !| NELMAX         |-->| MAXIMUM NUMBER OF ELEMENTS
00066 !| NEWSL          |<->| MODIFIED FREE SURFACE, PER ELEMENT
00067 !| OLDSL          |-->| REAL FREE SURFACE, PER POINT
00068 !| ZF             |-->| BATHYMETRY
00069 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00070 !
00071       IMPLICIT NONE
00072       INTEGER LNG,LU
00073       COMMON/INFO/LNG,LU
00074 !
00075 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00076 !
00077       INTEGER, INTENT(IN)             :: NELEM,NELMAX
00078       DOUBLE PRECISION, INTENT(INOUT) :: NEWSL(NELMAX,4)
00079       DOUBLE PRECISION, INTENT(IN)    :: OLDSL(*),ZF(*)
00080       INTEGER, INTENT(IN)             :: IKLE(NELMAX,4)
00081 !
00082 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00083 !
00084       INTEGER IELEM,IK(4),J(4)
00085       DOUBLE PRECISION SLM
00086 !
00087 !-----------------------------------------------------------------------
00088 !
00089       INTRINSIC MAX
00090 !
00091 !-----------------------------------------------------------------------
00092 !
00093 !  1) SORTS (ASCENDING ORDER) THE BOTTOM ELEVATIONS AND POTENTIALLY
00094 !     CORRECTS THE FREE SURFACE ELEVATION FOR DRYING ELEMENTS
00095 !
00096 !-----------------------------------------------------------------------
00097 !
00098       DO IELEM = 1 , NELEM
00099 !
00100       IK(1) = IKLE(IELEM,1)
00101       J (1) = 1
00102       IK(2) = IKLE(IELEM,2)
00103       J (2) = 2
00104       IK(3) = IKLE(IELEM,3)
00105       J (3) = 3
00106       IK(4) = IKLE(IELEM,4)
00107       J (4) = 4
00108 !
00109       IF (ZF(IK(2)).LT.ZF(IK(1)))  THEN
00110         J(2)=1
00111         J(1)=2
00112       ENDIF
00113       IF (ZF(IK(3)).LT.ZF(IK(J(2)))) THEN
00114         J(3)=J(2)
00115         J(2)=3
00116         IF (ZF(IK(3)).LT.ZF(IK(J(1)))) THEN
00117           J(2)=J(1)
00118           J(1)=3
00119         ENDIF
00120       ENDIF
00121       IF (ZF(IK(4)).LT.ZF(IK(J(3)))) THEN
00122         J(4)=J(3)
00123         J(3)=4
00124         IF (ZF(IK(4)).LT.ZF(IK(J(2)))) THEN
00125           J(3)=J(2)
00126           J(2)=4
00127           IF (ZF(IK(4)).LT.ZF(IK(J(1)))) THEN
00128             J(2)=J(1)
00129             J(1)=4
00130           ENDIF
00131         ENDIF
00132       ENDIF
00133 !
00134       SLM=OLDSL(IK(J(1)))
00135       NEWSL(IELEM,J(1))=SLM
00136       NEWSL(IELEM,J(2))=OLDSL(IK(J(2)))-MAX(0.D0,ZF(IK(J(2)))-SLM)
00137       SLM=MAX(SLM,NEWSL(IELEM,J(2)))
00138       NEWSL(IELEM,J(3))=OLDSL(IK(J(3)))-MAX(0.D0,ZF(IK(J(3)))-SLM)
00139       SLM=MAX(SLM,NEWSL(IELEM,J(3)))
00140       NEWSL(IELEM,J(4))=OLDSL(IK(J(4)))-MAX(0.D0,ZF(IK(J(4)))-SLM)
00141 !
00142       ENDDO ! IELEM
00143 !
00144 !-----------------------------------------------------------------------
00145 !
00146       RETURN
00147       END

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