The TELEMAC-MASCARET system  trunk
bedload_diffin_gaia.f
Go to the documentation of this file.
1 ! ******************************
2  SUBROUTINE bedload_diffin_gaia
3 ! ******************************
4 !
5  &(u2d, v2d, nbor, xnebor, ynebor, maskel, nelbor, nptfr,
6  & kent, ksort, klog, kdir, kddl, kneu, msk, clt, litbor,
7  & masktr, limtra,iklbor,neleb,nelebx)
8 !
9 !***********************************************************************
10 ! GAIA
11 !***********************************************************************
12 !
14 !
15 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
38 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
39 !
40  USE interface_gaia, ex_bedload_diffin => bedload_diffin_gaia
41  USE bief
43  IMPLICIT NONE
44 !
45 !!-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
46 !
47  TYPE(bief_obj), INTENT(IN) :: U2D,V2D,NBOR,XNEBOR,YNEBOR
48  TYPE(bief_obj), INTENT(IN) :: MASKEL,NELBOR
49  INTEGER, INTENT(IN) :: NPTFR,KENT,KSORT,KLOG
50  INTEGER, INTENT(IN) :: KDIR,KDDL,KNEU,NELEB,NELEBX
51  INTEGER, INTENT(IN) :: IKLBOR(nelebx,2)
52  LOGICAL, INTENT(IN) :: MSK
53  TYPE(bief_obj), INTENT(INOUT) :: CLT
54  TYPE(bief_obj), INTENT(INOUT) :: LITBOR, MASKTR, LIMTRA
55 !
56 !!-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
57 !
58  INTEGER :: K,K1,K2,IELEB
59  DOUBLE PRECISION :: USCALN,C
60  INTEGER, PARAMETER :: DIR = 1
61  INTEGER, PARAMETER :: DDL = 2
62  INTEGER, PARAMETER :: NEU = 3
63 !
64 !======================================================================!
65 !======================================================================!
66 ! PROGRAM !
67 !======================================================================!
68 !======================================================================!
69 !
70 ! ******************************************************
71 ! I - TYPES OF BOUNDARY CONDITIONS FOR THE TRACER
72 ! MAY BE MODIFIED DEPENDING ON THE SIGN OF U.N
73 ! FOR THE LIQUID BOUNDARIES (N : OUTGOING NORMAL)
74 ! ******************************************************
75 !
76  DO k = 1, nptfr
77  clt%I(k) = litbor%I(k)
78 ! I.1 - LIQUID BOUNDARIES
79 ! --------------------------------------
80  IF (clt%I(k) == kent) THEN
81  uscaln = u2d%R(nbor%I(k))*xnebor%R(k)
82  & + v2d%R(nbor%I(k))*ynebor%R(k)
83 ! OUTGOING VELOCITY, FREE TRACER
84 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
85  IF (uscaln >= 0.d0) clt%I(k) = ksort
86  ELSEIF(clt%I(k) == ksort) THEN
87  uscaln = u2d%R(nbor%I(k))*xnebor%R(k)
88  & + v2d%R(nbor%I(k))*ynebor%R(k)
89 ! ENTERING VELOCITY, FREE TRACER
90 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
91  IF (uscaln <= 0.d0) clt%I(k) = kent
92  ENDIF
93  ENDDO
94 !
95 ! ****************************************************************
96 ! II - MASKTR ARRAY DEFINED AS A FUNCTION OF CLT
97 ! EQUALS 1 FOR A SEGMENT OF NEUMANN TYPE, AND 0 OTHERWISE
98 ! A SEGMENT IS OF NEUMANN TYPE IF THE USER SPECIFIES AT LEAST
99 ! ONE OF ITS NODES AS NEUMANN.
100 ! ****************************************************************
101 !
102  CALL os('X=0 ', x=masktr)
103 !
104  DO ieleb = 1 , neleb
105  k1=iklbor(ieleb,1)
106  k2=iklbor(ieleb,2)
107 ! II.1 - NEUMANN TYPE SEGMENTS
108 ! -------------------------------
109  IF(clt%I(k1).EQ.klog.OR.clt%I(k2).EQ.klog) THEN
110  masktr%ADR(neu)%P%R(ieleb) = 1.d0
111 ! II.2 - OUTGOING TYPE SEGMENTS
112 ! ------------------------------
113  ELSEIF(clt%I(k1).EQ.kent.AND.clt%I(k2).EQ.ksort) THEN
114  masktr%ADR(ddl)%P%R(ieleb) = 1.d0
115  ELSEIF (clt%I(k1).EQ.ksort.OR.clt%I(k2).EQ.ksort) THEN
116  masktr%ADR(ddl)%P%R(ieleb) = 1.d0
117 ! II.3 - OUTGOING TYPE SEGMENTS
118 ! ------------------------------
119  ELSEIF(clt%I(k1).EQ.ksort.AND.clt%I(k2).EQ.kent) THEN
120  masktr%ADR(ddl)%P%R(ieleb) = 1.d0
121  ELSEIF(clt%I(k1).EQ.kent.OR.clt%I(k2).EQ.kent) THEN
122  masktr%ADR(dir)%P%R(ieleb) = 1.d0
123  ELSE
124  WRITE(lu,102)
125  CALL plante(1)
126  stop
127  ENDIF
128  ENDDO
129 !
130 ! ***********************
131 ! III - POTENTIAL MASKING
132 ! ***********************
133 !
134  IF(msk) THEN
135  DO ieleb = 1 , neleb
136  c=maskel%R(nelbor%I(ieleb))
137  masktr%ADR(dir)%P%R(ieleb) = masktr%ADR(dir)%P%R(ieleb)*c
138  masktr%ADR(ddl)%P%R(ieleb) = masktr%ADR(ddl)%P%R(ieleb)*c
139  masktr%ADR(neu)%P%R(ieleb) = masktr%ADR(neu)%P%R(ieleb)*c
140  ENDDO
141  ENDIF
142 !
143 ! **************************************************************
144 ! IV - FROM PHYSICAL CONDITION TO TECHNICAL CONDITIONS
145 ! **************************************************************
146 !
147  DO k = 1, nptfr
148 ! IV.1 - 'INCOMING' BOUNDARY : IMPOSED TRACER
149 ! -----------------------------------------
150  IF(clt%I(k).EQ.kent) THEN
151  limtra%I(k) = kdir
152  ELSEIF(clt%I(k).EQ.ksort) THEN
153  limtra%I(k) = kddl
154 ! IV.2 - SOLID BOUNDARY : NEUMANN CONDITIONS
155 ! ------------------------------------
156  ELSEIF(clt%I(k).EQ.klog ) THEN
157  limtra%I(k) = kneu
158 ! IV.3 - ERROR: UNKNOWN LITBOR VALUE
159 ! ----------------------------------------
160  ELSE
161  WRITE(lu,12) k, litbor%I(k)
162  CALL plante(1)
163  stop
164  ENDIF
165  ENDDO
166 !-------------------------------------------------------------------!
167 !-------------------------------------------------------------------!
168 102 FORMAT(' BEDLOAD_DIFFIN_GAIA: UNEXPECTED CASE')
169 12 FORMAT(' BEDLOAD_DIFFIN_GAIA: POINT ',1i8,' LITBOR= ',1i8,' ?')
170 !-------------------------------------------------------------------!
171 !
172 !======================================================================!
173 !======================================================================!
174 !
175  RETURN
176  END
subroutine bedload_diffin_gaia(U2D, V2D, NBOR, XNEBOR, YNEBOR, MASKEL, NELBOR, NPTFR, KENT, KSORT, KLOG, KDIR, KDDL, KNEU, MSK, CLT, LITBOR, MASKTR, LIMTRA, IKLBOR, NELEB, NELEBX)
subroutine os(OP, X, Y, Z, C, IOPT, INFINI, ZERO)
Definition: os.f:7
Definition: bief.f:3