vc01pp.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\utils\bief\vc01pp.f
00002 !
00070                      SUBROUTINE VC01PP
00071 !                    *****************
00072 !
00073      &( XMUL,SF,F,Z,SURFAC,
00074      &  IKLE1,IKLE2,IKLE3,IKLE4,IKLE5,IKLE6,NELEM,NELMAX,
00075      &  W1,W2,W3,W4,W5,W6)
00076 !
00077 !***********************************************************************
00078 ! BIEF   V6P1                                   21/08/2010
00079 !***********************************************************************
00080 !
00081 !
00082 !
00083 !
00084 !
00085 !
00086 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00087 !| F              |-->| FUNCTION USED IN THE VECTOR FORMULA
00088 !| IKLE1          |-->| FIRST POINT OF PRISMS
00089 !| IKLE2          |-->| SECOND POINT OF PRISMS
00090 !| IKLE3          |-->| THIRD POINT OF PRISMS
00091 !| IKLE4          |-->| FOURTH POINT OF PRISMS
00092 !| IKLE5          |-->| FIFTH POINT OF PRISMS
00093 !| IKLE6          |-->| SIXTH POINT OF PRISMS
00094 !| NELEM          |-->| NUMBER OF ELEMENTS
00095 !| NELMAX         |-->| MAXIMUM NUMBER OF ELEMENTS
00096 !| SF             |-->| BIEF_OBJ STRUCTURE OF F
00097 !| SURFAC         |-->| AREA OF TRIANGLES
00098 !| W1             |<--| RESULT IN NON ASSEMBLED FORM
00099 !| W2             |<--| RESULT IN NON ASSEMBLED FORM
00100 !| W3             |<--| RESULT IN NON ASSEMBLED FORM
00101 !| W4             |<--| RESULT IN NON ASSEMBLED FORM
00102 !| W5             |<--| RESULT IN NON ASSEMBLED FORM
00103 !| W6             |<--| RESULT IN NON ASSEMBLED FORM
00104 !| XMUL           |-->| MULTIPLICATION COEFFICIENT
00105 !| Z              |-->| ELEVATIONS OF POINTS
00106 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00107 !
00108       USE BIEF, EX_VC01PP => VC01PP
00109 !
00110       IMPLICIT NONE
00111       INTEGER LNG,LU
00112       COMMON/INFO/LNG,LU
00113 !
00114 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00115 !
00116       INTEGER, INTENT(IN) :: NELEM,NELMAX
00117       INTEGER, INTENT(IN) :: IKLE1(NELMAX),IKLE2(NELMAX),IKLE3(NELMAX)
00118       INTEGER, INTENT(IN) :: IKLE4(NELMAX),IKLE5(NELMAX),IKLE6(NELMAX)
00119 !
00120       DOUBLE PRECISION, INTENT(IN) :: Z(*)
00121       DOUBLE PRECISION, INTENT(IN) :: SURFAC(NELMAX)
00122       DOUBLE PRECISION,INTENT(INOUT)::W1(NELMAX),W2(NELMAX),W3(NELMAX)
00123       DOUBLE PRECISION,INTENT(INOUT)::W4(NELMAX),W5(NELMAX),W6(NELMAX)
00124       DOUBLE PRECISION, INTENT(IN) :: XMUL
00125 !
00126 !     STRUCTURE OF F AND REAL DATA
00127 !
00128       TYPE(BIEF_OBJ),   INTENT(IN) :: SF
00129       DOUBLE PRECISION, INTENT(IN) :: F(*)
00130 !
00131 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00132 !
00133       INTEGER IELEM,IELMF
00134       DOUBLE PRECISION SUR360,COEF,H1,H2,H3,SHT,SH1,SH2,SH3
00135       DOUBLE PRECISION F1,F2,F3,F4,F5,F6,SFI,SFS,SF1,SF2,SF3,SF4,SF5,SF6
00136       DOUBLE PRECISION HF1,HF2,HF3,HF4,HF5,HF6,SHFI,SHFS
00137       DOUBLE PRECISION SHF1,SHF2,SHF3,SHF4,SHF5,SHF6
00138 !
00139 !***********************************************************************
00140 !
00141       IELMF=SF%ELM
00142 !
00143 !-----------------------------------------------------------------------
00144 !
00145 !   F IS LINEAR
00146 !
00147       IF(IELMF.EQ.41) THEN
00148 !
00149         SUR360 = XMUL / 360.D0
00150 !
00151         DO IELEM = 1 , NELEM
00152 !
00153           COEF = SUR360 * SURFAC(IELEM)
00154 !
00155           H1  = COEF * (Z(IKLE4(IELEM)) - Z(IKLE1(IELEM)))
00156           H2  = COEF * (Z(IKLE5(IELEM)) - Z(IKLE2(IELEM)))
00157           H3  = COEF * (Z(IKLE6(IELEM)) - Z(IKLE3(IELEM)))
00158           SHT = H1 + H2 + H3
00159           SH1 = H1 + SHT
00160           SH2 = H2 + SHT
00161           SH3 = H3 + SHT
00162 !
00163           F1  = F(IKLE1(IELEM))
00164           F2  = F(IKLE2(IELEM))
00165           F3  = F(IKLE3(IELEM))
00166           F4  = F(IKLE4(IELEM))
00167           F5  = F(IKLE5(IELEM))
00168           F6  = F(IKLE6(IELEM))
00169           SFI = F1 + F2 + F3
00170           SFS = F4 + F5 + F6
00171           SF1 = F1 + SFI
00172           SF2 = F2 + SFI
00173           SF3 = F3 + SFI
00174           SF4 = F4 + SFS
00175           SF5 = F5 + SFS
00176           SF6 = F6 + SFS
00177 !
00178           HF1  = H1 * F1
00179           HF2  = H2 * F2
00180           HF3  = H3 * F3
00181           HF4  = H1 * F4
00182           HF5  = H2 * F5
00183           HF6  = H3 * F6
00184           SHFI = HF1 + HF2 + HF3
00185           SHFS = HF4 + HF5 + HF6
00186           SHF1 = HF1 + SHFI
00187           SHF2 = HF2 + SHFI
00188           SHF3 = HF3 + SHFI
00189           SHF4 = HF4 + SHFS
00190           SHF5 = HF5 + SHFS
00191           SHF6 = HF6 + SHFS
00192 !
00193           W1(IELEM) = SH1 * (SF1+SF1+SF4) + SHF1 + SHF1 + SHF4
00194           W2(IELEM) = SH2 * (SF2+SF2+SF5) + SHF2 + SHF2 + SHF5
00195           W3(IELEM) = SH3 * (SF3+SF3+SF6) + SHF3 + SHF3 + SHF6
00196           W4(IELEM) = SH1 * (SF1+SF4+SF4) + SHF1 + SHF4 + SHF4
00197           W5(IELEM) = SH2 * (SF2+SF5+SF5) + SHF2 + SHF5 + SHF5
00198           W6(IELEM) = SH3 * (SF3+SF6+SF6) + SHF3 + SHF6 + SHF6
00199 !
00200         ENDDO ! IELEM
00201 !
00202 !-----------------------------------------------------------------------
00203 !
00204       ELSE
00205 !
00206         IF (LNG.EQ.1) WRITE(LU,101) IELMF,SF%NAME
00207         IF (LNG.EQ.2) WRITE(LU,102) IELMF,SF%NAME
00208 101     FORMAT(1X,'VC01PP (BIEF) :',/,
00209      &         1X,'DISCRETISATION DE F : ',1I6,' CAS NON PREVU',/,
00210      &         1X,'NOM REEL DE F : ',A6)
00211 102     FORMAT(1X,'VC01PP (BIEF) :',/,
00212      &         1X,'DISCRETISATION OF F : ',1I6,' NOT IMPLEMENTED',/,
00213      &         1X,'REAL NAME OF F: ',A6)
00214         CALL PLANTE(1)
00215         STOP
00216 !
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