The TELEMAC-MASCARET system  trunk
cvsp_main_gaia.f
Go to the documentation of this file.
1 ! *************************
2  SUBROUTINE cvsp_main_gaia
3 ! *************************
4 !
5  &(zfcl_w,zf,nsicla,npoin)
6 !
7 !***********************************************************************
8 ! GAIA V8P1 16/05/2017
9 !***********************************************************************
10 !
13 !
17 !
22 !
27 !
32 !
38 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
43 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
44 !
45  USE bief
48  & pro_d,pro_max,pro_max_max,percou,
49  & hn,lt,dt,mesh,z,pro_f,zero,zr
50 !
52  USE cvsp_outputfiles_gaia, ONLY: cp
53  USE interface_parallel, ONLY: p_dsum, p_isum
54  IMPLICIT NONE
55 !
56 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
57 !
58  type(bief_obj), INTENT(IN) :: zfcl_w,zf
59  INTEGER, INTENT(IN) :: NSICLA,NPOIN
60 !
61 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
62 !
63  INTEGER IAMCASE, ISICLA, JG
64  LOGICAL RET
65  INTEGER I,J,K,ARRET,ARRET2
66  DOUBLE PRECISION DZFCL,EVL,AT,DELTA,KORR,SUMF
67  INTEGER KK,PROMAX
68 !
69 !-----------------------------------------------------------------------
70 !
71  arret=0
72  at = dt*lt/percou
73  cp = .false. ! If true: A lot of debug prints!
74 !
75 !-----------------------------------------------------------------------
76 ! INITIAL CHECK FOR DEBUGGING
77 !-----------------------------------------------------------------------
78 !
79 
80  DO j=1,npoin
81  DO k = 1, pro_max(j)
82  !REMOVES NUMERIC INSTABILITIES
83  ret = cvsp_check_f_gaia(j,k,'INIT_CVSP_MAIN: ')
84  ENDDO
85  ENDDO
86 !
87 !-----------------------------------------------------------------------
88 ! CHECK FOR RIGID BED ERRORS
89 !RK not needed anymore for gaia, only ES... calcultes the layer thickness
90 !-----------------------------------------------------------------------
91  DO j=1,npoin
92  IF(z%R(j)-zf%R(j).LT.0.d0) THEN
93  IF(cp) WRITE(lu,*) .LT.'UHM_ZZF_BEF ',at,z%R(j),zf%R(j),
94  & hn%R(j),(z%R(j)-zf%R(j))-hn%R(j)
95  CALL cvsp_p_gaia('./','Z_', j)
96  ENDIF
97  ENDDO
98 !
99 !-----------------------------------------------------------------------
100 ! FOR ALL POINTS AND FOR ALL CLASSES
101 !-----------------------------------------------------------------------
102  DO j=1,npoin
103  jg = j
104  IF (ncsize.GT.1) jg = mesh%KNOLG%I(j)
105  evl = 0.d0
106  DO isicla = 1,nsicla
107  evl = zfcl_w%ADR(isicla)%P%R(j) + evl
108  END DO
109 !
110 ! DEBUG INFO
111  iamcase = 0
112  IF (cvsp_db_gaia(jg,0)) CALL cvsp_p_gaia('./','V_A',jg)
113 ! DEBUG INFO
114 !
115 !-----------------------------------------------------------------------
116 ! ADD SECTION IF DEPOSITION IN SUM OVER ALL CLASSES
117 !-----------------------------------------------------------------------
118  IF(evl.GT.0) THEN
119  CALL cvsp_add_section_gaia(j)
120  ENDIF
121 !
122  DO i=1,nsicla
123  dzfcl = zfcl_w%ADR(i)%P%R(j)
124  !START DEPOSITION IN SUM OVER ALL CASES
125  IF (evl.GT.0d0) THEN
126  IF (dzfcl.GT.0.d0) THEN
127  CALL cvsp_add_fraction_gaia(j,i,dzfcl)
128  iamcase = 1 + iamcase !DEBUG INFO
129  !CHECK
130  DO k = 1, pro_max(j)
131  ret = cvsp_check_f_gaia(j,k,' EVL>0: A ')
132  ENDDO
133  ELSEIF( dzfcl.LT.0.d0) THEN
134  CALL cvsp_rm_fraction_gaia(j,i,dzfcl)
135  iamcase = 10 + iamcase !DEBUG INFO
136  !CHECK
137  DO k = 1, pro_max(j)
138  ret = cvsp_check_f_gaia(j,k,' EVL>0: B ')
139  ENDDO
140  ENDIF
141  ENDIF
142 !-----------------------------------------------------------------------
143 ! EROSION IN SUM OVER ALL CLASSES
144 !-----------------------------------------------------------------------
145  IF(evl.LT.0.d0) THEN
146  IF (dzfcl.GT.0.d0) THEN
147  CALL cvsp_add_fraction_gaia(j,i,dzfcl)
148  iamcase = 100 + iamcase !DEBUG INFO
149  ELSEIF(dzfcl.LT.0.d0) THEN
150  CALL cvsp_rm_fraction_gaia(j,i,dzfcl)
151  iamcase = 1000 + iamcase !DEBUG INFO
152  ENDIF ! DZFCL
153  !CHECK
154  DO k = 1, pro_max(j)
155  IF(cvsp_check_f_gaia(j,k,' EVL<0: ')
156  & .EQV..false.)THEN
157  IF(cp) WRITE(lu,*)'--> CVSP CF Case: ',iamcase
158  ENDIF
159  ENDDO
160  ENDif! EVL < 0
161  ENDDO !NSICLA
162 !
163 ! REMOVING EMPTY SECTIONS
164  DO k=2,pro_max(j)
165  promax = pro_max(j)
166  sumf = 0.d0
167  DO i=1,nsicla
168  sumf = sumf + pro_f(j,k,i)
169  END DO
170  IF(sumf.EQ.0.d0) THEN
171  promax = promax - 1
172  DO kk=k,promax
173  DO i=1,nsicla
174  pro_d(j,kk,i) = pro_d(j,kk+1,i)
175  pro_f(j,kk,i) = pro_f(j,kk+1,i)
176  END DO
177  END DO
178  ENDIF
179  IF(promax.EQ.k) GOTO 999
180  END DO !K=2,PRO_MAX(J)
181 999 pro_max(j) = promax
182 
183 !-----------------------------------------------------------------------
184 ! WE ARE RUNNING OUT OF SECTION MEMORY! COMPRESS NOW!
185 !-----------------------------------------------------------------------
186  IF ((pro_max(j).GT.pro_max_max/4*3).OR.
187  & (pro_max_max-pro_max(j).LT.8*nsicla)) THEN
188  DO k = 1, pro_max(j)
189  !REMOVES NUMERIC INSTABILITIES
190  ret = cvsp_check_f_gaia(j,k,' Before DP: ')
191  ENDDO
192  CALL cvsp_compress_dp_gaia(j, 1.0d-5)
193  DO k = 1, pro_max(j)
194  !REMOVES NUMERIC INSTABILITIES
195  ret = cvsp_check_f_gaia(j,k,' After DP: ')
196  ENDDO
197  ENDIF
198 !-----------------------------------------------------------------------
199 ! SYNCHRONICE VSP WITH LAYER (FOR DEBUGGING ...)
200 !-----------------------------------------------------------------------
201  delta = zf%R(j) - pro_d(j, pro_max(j), 1)
202 !
203  IF (delta.NE.0.d0) THEN
204  DO i = 1 , nsicla
205  DO k = 2, pro_max(j)
206  pro_d(j, k, i) = pro_d(j, k, i) + delta
207  ENDDO
208  ENDDO
209 ! problem due to adopting ZF and Pro_d top most layer
210 ! bottom most layer could be higher than second top most layer
211 ! -> deleting last layer
212  IF(pro_d(j,2,1).LT.pro_d(j,1,1)) THEN
213  WRITE(lu,*) 'Problem bottom',pro_d(j,2,1),pro_d(j,1,1),
214  & pro_max(j)
215  DO i=1,nsicla
216  DO k=pro_max(j),2,-1
217  pro_d(j,k-1,i) = pro_d(j,k,i)
218  pro_f(j,k-1,i) = pro_f(j,k,i)
219  END DO
220  END DO
221  pro_max(j) = pro_max(j)-1
222  ENDIF
223  ENDIF
224 !-----------------------------------------------------------------------
225 !FINAL CHECK ON NEW FRACTIONS AND STEADY STADE
226 !-----------------------------------------------------------------------
227  DO k = 1, pro_max(j)
228 ! REMOVES NUMERIC INSTABILITIES
229  ret = cvsp_check_f_gaia(j,k,' FINAL: ')
230  ENDDO
231  CALL cvsp_check_steady_gaia(j)
232 !
233 ! END FOR ALL POINTS
234  ENDDO
235 !
236 !-----------------------------------------------------------------------
237 ! GENERATE NEW LAYERS FROM SORTING PROFILE
238 !-----------------------------------------------------------------------
239 !
240 !in make_actlay werden noch mal checks durchgefuehrt, die ggf.
241 ! pro_f und pro_d veraendern... daher vor die Ausgabe gezogen!
242 !
243  CALL cvsp_make_actlay_gaia()
244 !
245 !-----------------------------------------------------------------------
246 ! PRINT OUT SORTING PROFILE FOR SELECTED GLOBAL POINT NUMBERS!INSERT
247 !-----------------------------------------------------------------------
248 !
249  IF((cvsm_out).OR.(cvsp_db_gaia(-1,-1).EQV..true.)) THEN
250 ! WRITES THE FULL VSP AS SERAFIN
251  IF (cvsm_out_full) CALL cvsp_write_profile_gaia()
252 ! WRITES THE VSP FOR SINGLE POINTS
253  DO kk = 1, 100
254  IF (cvsmoutput(kk).GT.0) THEN
255  CALL cvsp_p_gaia('./','V_', cvsmoutput(kk))
256  ENDIF
257  ENDDO
258  END IF
259 !
260 !-----------------------------------------------------------------------
261 ! CHECK FOR RIGID BED ERRORS
262 !-----------------------------------------------------------------------
263 ! -- this is not needed in Gaia because the rigid bed is not supported anymore
264 ! instead only es is used
265 ! DO J=1,NPOIN
266 ! IF (ZR%R(J).GT.ZF%R(J).OR.
267 ! & ABS(PRO_D(J,1,1)-ZR%R(J)).GT.0.D0) THEN
268 ! WRITE(LU,*)'rigid bed error',J,PRO_D(J,1,1),ZR%R(J),ZF%R(J)
269 ! IF(CP)WRITE(LU,*) 'UHM_Z.LT.ZF ', I,AT,Z%R(J),ZF%R(J),
270 ! & HN%R(J),(Z%R(J)-ZF%R(J))-HN%R(J)
271 !! CALL CVSP_P_GAIA('./','Z_', J)
272 ! STOP
273 ! END IF
274 ! ENDDO
275 !
276 !-----------------------------------------------------------------------
277 ! PRINT OUT NEW LAYERS FOR SELECTED GLOBAL POINT NUMBERS
278 !-----------------------------------------------------------------------
279 !
280  IF((cvsm_out).OR.(cvsp_db_gaia(-1,-1).EQV..true.)) THEN
281  DO kk = 1,100
282  IF (cvsmoutput(kk).GT.0) THEN
283  CALL layers_p_gaia('./','Pnt_', cvsmoutput(kk))
284  ENDIF
285  ENDDO
286  END IF
287 !
288 !-----------------------------------------------------------------------
289 ! CLEAN STOP FOR ALL PROCESSORS IF PROBLEM
290 !-----------------------------------------------------------------------
291 !
292  arret2=arret
293  IF(ncsize.GT.1) arret2=p_isum(arret)
294  IF(arret2.GT.0) THEN
295  WRITE(lu,*) 'STOP AFTER AN ERROR IN LAYER'
296  IF(arret.EQ.0) THEN
297  WRITE(lu,*) 'IN ',arret2,' PROCESSOR(S)'
298  ENDIF
299  CALL plante(1)
300  stop
301  ENDIF
302 !
303 !-----------------------------------------------------------------------
304 !
305  RETURN
306  END SUBROUTINE
307 
subroutine cvsp_main_gaia(ZFCL_W, ZF, NSICLA, NPOIN)
Definition: cvsp_main_gaia.f:7
subroutine cvsp_add_section_gaia(J)
subroutine layers_p_gaia(PATH_PRE, FILE_PRE, JG)
Definition: layers_p_gaia.f:7
subroutine cvsp_p_gaia(PATH_PRE, FILE_PRE, JG)
Definition: cvsp_p_gaia.f:7
subroutine cvsp_add_fraction_gaia(J, I, DZFCL)
subroutine cvsp_check_steady_gaia(J)
logical cvsm_out_full
C-VSM_FULL WRITES OUT (OR NOT) EVER.
logical cp
Logical for debug printouts.
integer function p_isum(MYPART)
Definition: p_isum.F:7
integer, dimension(100) cvsmoutput
CHOOSE POINTS or FULL MODEL AS PRINTOUT.
subroutine cvsp_rm_fraction_gaia(J, I, DZFCL)
subroutine cvsp_compress_dp_gaia(J, THRESHOLD)
subroutine cvsp_make_actlay_gaia
double precision function p_dsum(MYPART)
Definition: p_dsum.F:7
recursive logical function cvsp_check_f_gaia(J, K, SOMETEXT)
logical cvsm_out
C-VSM WRITES OUT (OR NOT) IN THIS TIMESTEP.
logical function cvsp_db_gaia(J_GLOBAL, TIMESTAMP)
Definition: cvsp_db_gaia.f:7
subroutine cvsp_write_profile_gaia
Definition: bief.f:3