Newer
Older
WAUTELET Philippe
committed
!MNH_LIC Copyright 1994-2020 CNRS, Meteo-France and Universite Paul Sabatier
!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
WAUTELET Philippe
committed
!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!MNH_LIC for details. version 1.
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
!-----------------------------------------------------------------
!##################
MODULE MODI_BUDGET
!##################
!
INTERFACE
!
SUBROUTINE BUDGET(PVARS,KBUDN,HBUVAR)
!
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PVARS ! Source
INTEGER , INTENT(IN) :: KBUDN ! variable number
CHARACTER (LEN=*) , INTENT(IN) :: HBUVAR ! Identifier of the Budget of the
! variable that is considered
!
END SUBROUTINE BUDGET
!
END INTERFACE
!
END MODULE MODI_BUDGET
! #####################################
SUBROUTINE BUDGET(PVARS,KBUDN,HBUVAR)
! #####################################
!
!!**** *BUDGET* - routine to call the BUDGET routine.
!!
!!
!! PURPOSE
!! -------
! This routine selects the variable RVAR, the budget of which is
! processed in the inner routine BUDGET_CASE. !
!!** METHOD
!! ------
!!
!!
!!
!! EXTERNAL
!! --------
!! CART_COMPRESS
!! MASK_COMPRESS
!!
!! IMPLICIT ARGUMENTS
!! ------------------
!! Module MODD_BUDGET
!! XBURU : budget array of the variable RU
!! XBURV : budget array of the variable RV
!! XBURW : budget array of the variable RW
!! XBURTH : budget array of the variable RTH
!! XBURTKE : budget array of the variable RTKE
!! XBURRV : budget array of the variable RRV
!! XBURRC : budget array of the variable RRC
!! XBURRR : budget array of the variable RRR
!! XBURRI : budget array of the variable RRI
!! XBURRS : budget array of the variable RRS
!! XBURRG : budget array of the variable RRG
!! XBURRH : budget array of the variable RRH
!! XBURTKE : budget array of the variable RTKE
!! XBURSV(x) : budget array of the variable RSVx
!!
!! REFERENCE
!! ---------
!! None
!!
!! AUTHOR
!! ------
!! J. Nicolau * Meteo France *
!!
!! MODIFICATIONS
!! -------------
!! Original 30/08/94
!! J. Stein 26/06/96 add the 'OF','NO' option
!! J.-P. Pinty 12/12/96 simplifies the coding
!! V. Masson 06/10/02 add LES budgets
!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
Juan Escobar
committed
!! J.Escobar : 09/07/2019 : for bit reproductiblity use MPPDB_CHECK with PRECISION=0.0 error
!!
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
! ------------
!
USE MODD_BUDGET
USE MODD_LUNIT
!USE MODD_CONF_n
USE MODD_CONF, ONLY : LCHECK
USE MODD_NSV, ONLY : NSV
!
USE MODI_LES_BUDGET
USE MODI_CART_COMPRESS
USE MODI_MASK_COMPRESS
!
USE MODI_SECOND_MNH
!
IMPLICIT NONE
!
!
!* 0.1 Declarations of arguments :
!
INTEGER , INTENT(IN) :: KBUDN ! variable number
REAL, DIMENSION(:,:,:), INTENT(IN) :: PVARS ! source of the variable
CHARACTER (LEN=*) , INTENT(IN) :: HBUVAR ! Identifier of the Budget of the
! variable that is considered
INTEGER :: IBUSV ! Index of the SV
!
INTEGER :: ILUOUT0 ! Logical unit number for output-listing
INTEGER :: IRESP ! Return code of FM-routines
!
REAL :: ZTIME1 ! CPU time counter
REAL :: ZTIME2 ! CPU time counter
!
!-------------------------------------------------------------------------------
!
!* Reproductivity checks
! Warning: requires an adaptation of the makefile in order to run two runs in
! parallel for comparison
!
IF (LCHECK) THEN
print*,'BUDGET :',HBUVAR
Juan Escobar
committed
CALL MPPDB_CHECK3D(PVARS,HBUVAR,PRECISION)
!* call to LES budgets
!
IF (LLES_CALL) CALL LES_BUDGET(PVARS,KBUDN,HBUVAR)
!
!* call to prognostic variables budgets
!
IF (.NOT. LBU_ENABLE) RETURN
!
SELECT CASE (KBUDN)
WAUTELET Philippe
committed
CASE ( NBUDGET_U )
WAUTELET Philippe
committed
CASE ( NBUDGET_V )
WAUTELET Philippe
committed
CASE ( NBUDGET_W )
IF (.NOT. LBU_RW) RETURN
CASE (NBUDGET_TH)
WAUTELET Philippe
committed
CASE ( NBUDGET_TKE )
WAUTELET Philippe
committed
CASE ( NBUDGET_RV )
WAUTELET Philippe
committed
CASE ( NBUDGET_RC )
WAUTELET Philippe
committed
CASE (NBUDGET_RR )
WAUTELET Philippe
committed
CASE ( NBUDGET_RI )
WAUTELET Philippe
committed
CASE ( NBUDGET_RS )
WAUTELET Philippe
committed
CASE ( NBUDGET_RG )
WAUTELET Philippe
committed
CASE ( NBUDGET_RH )
WAUTELET Philippe
committed
CASE ( NBUDGET_SV1 : )
IF (.NOT. LBU_RSV) RETURN
END SELECT
!
!-------------------------------------------------------------------------------
!
CALL SECOND_MNH(ZTIME1)
!
SELECT CASE (KBUDN)
!
WAUTELET Philippe
committed
CASE ( NBUDGET_U ) ! ==> RU BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_V ) ! ==> RV BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_W ) ! ==> RW BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_TH ) ! ==> RTH BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_TKE ) ! ==> RTKE BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_RV ) ! ==> RRV BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_RC ) ! ==> RRC BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_RR ) ! ==> RRR BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_RI ) ! ==> RRI BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_RS ) ! ==> RRS BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_RG ) ! ==> RRG BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_RH ) ! ==> RRH BUDGET
WAUTELET Philippe
committed
CASE ( NBUDGET_SV1 : ) ! ==> RSVx BUDGET
IBUSV = KBUDN - ( NBUDGET_SV1 - 1 )
IF( IBUSV <= NSV ) THEN
CALL BUDGET_CASE(XBURSV(:,:,:,:,IBUSV))
ELSE
WRITE(UNIT=ILUOUT0,FMT='("BUDGET: SCALAR VARIABLE",I2," IS ABSENT !!")') &
IBUSV
WRITE(UNIT=ILUOUT0,FMT='("CHECK FOR THE CALL BUDGET OF THAT VARIABLE")')
!callabortstop
WAUTELET Philippe
committed
CALL PRINT_MSG(NVERB_FATAL,'BUD','BUDGET','')
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
END IF
END SELECT
!
CALL SECOND_MNH(ZTIME2)
!
XTIME_BU_PROCESS = XTIME_BU_PROCESS + ZTIME2 - ZTIME1
XTIME_BU = XTIME_BU + ZTIME2 - ZTIME1
!
!----------------------------------------------------------------------
CONTAINS
!----------------------------------------------------------------------
! ###############################
SUBROUTINE BUDGET_CASE(PBURVAR)
! ###############################
!
!!**** *BUDGET_CASE* - routine to call the BUDGET_CASE routine.
!!
!!
!! PURPOSE
!! -------
! This routine chooses the right call to the functions CART_COMPRESS
! or MASK_COMPRESS (which realize the compression of the source PVARS
! in the different directions) and achieves in function of HACTION (which
! determines the operations to be executed) the budget for the variable
! corresponding to the number KBUDN. The budget process counter is
! incremented by NBUINC depending on the number of active processes in the
! model.
!
!!** METHOD
!! ------
!!
!!
!!
!! EXTERNAL
!! --------
!! CART_COMPRESS
!! MASK_COMPRESS
!!
!! IMPLICIT ARGUMENTS
!! ------------------
!! Module MODD_BUDGET
!! CBUACTION : type of operation
!! CBUTYPE : budget type (CART,MASK or NONE)
!! NBUTIME : number of the budget step
!! NBUPROCCTR : process counter for each budget variable
!! PBURVAR : budget array of the variable RVAR
!!
!! REFERENCE
!! ---------
!! None
!!
!! AUTHOR
!! ------
!! J.-P. Pinty *Laboratoire d'Aerologie*
!!
!! MODIFICATIONS
!! -------------
!! Original 12/12/96
!! Modification 24/06/99 N. Asencio : budget // , the dimensions of the
!! budget arrays are implicit
!!
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
! ------------
!
USE MODI_CART_COMPRESS
USE MODI_MASK_COMPRESS
!
IMPLICIT NONE
!
!
!* 0.1 Declarations of arguments :
!
REAL, DIMENSION(:,:,:,:), INTENT(INOUT):: PBURVAR ! budget of variable RVAR
!
!* 0.2 Declarations of local variables :
CHARACTER (LEN=99) :: YBUVAR_ADJUSTED ! Adjusted string
CHARACTER (LEN=99) :: YBUCOMMENT_ADJUSTED ! Adjusted string
CHARACTER (LEN=99) :: YBUVAR ! local string
CHARACTER (LEN=99) :: YBUCOMMENT ! local string
INTEGER :: ILEN ! Number of non-blank char.
!
!
!* 1. SECURITY TEST
! -------------
!
YBUVAR = HBUVAR
YBUCOMMENT = CBUCOMMENT(KBUDN,NBUPROCCTR(KBUDN))
YBUVAR_ADJUSTED = ADJUSTR(YBUVAR)
YBUCOMMENT_ADJUSTED = ADJUSTR(YBUCOMMENT)
ILEN = LEN_TRIM( ADJUSTL(YBUVAR))
!
IF( CBUACTION(KBUDN,NBUCTR_ACTV(KBUDN))/='NO'.AND. &
CBUACTION(KBUDN,NBUCTR_ACTV(KBUDN))/='OF'.AND. &
CBUACTION(KBUDN,NBUCTR_ACTV(KBUDN))/='CC' ) THEN
IF( YBUVAR_ADJUSTED(100-ILEN:99) /= YBUCOMMENT_ADJUSTED(100-ILEN:99) &
.OR. ILEN==0 ) THEN
WRITE(UNIT=ILUOUT0,FMT='("BUDGET: WRONG BUDGET IDENTIFICATION !!")')
WRITE(UNIT=ILUOUT0,FMT='("BUDGET: PRESENT VARIABLE: ",I2)') KBUDN
WRITE(UNIT=ILUOUT0,FMT='("BUDGET: PRESENT IDENTIFIER: ",A99)') &
YBUVAR_ADJUSTED
WRITE(UNIT=ILUOUT0,FMT='("BUDGET: EXPECTED IDENTIFIER: ",A99)') &
YBUCOMMENT_ADJUSTED
WRITE(UNIT=ILUOUT0,FMT='("PLEASE CHECK THE CALL BUDGET OF THE VARIABLE")')
WRITE(UNIT=ILUOUT0,FMT='("AND THE BUDGET PROCESS ORDER IN INI_BUDGET !")')
!callabortstop
WAUTELET Philippe
committed
CALL PRINT_MSG(NVERB_FATAL,'BUD','BUDGET','')
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
END IF
END IF
!
! Budget integration in case of successful test
!
SELECT CASE (CBUTYPE)
!
!* 2. "CART" CASE
! -----------
!
CASE ('CART')
!
SELECT CASE (CBUACTION(KBUDN,NBUCTR_ACTV(KBUDN)))
!
!* 2.1 Budget beginning : initial fields
! filled in budget tabulars (NBUPROCCTR=1)
!
CASE('IG')
PBURVAR(:,:,:,1)=CART_COMPRESS(PVARS)
!
!* 2.2 average tendancy filled every time
! step in budget tabulars (NBUPROCCTR=3)
!
CASE('ES')
PBURVAR(:,:,:,3)=PBURVAR(:,:,:,3)+CART_COMPRESS(PVARS)/NBUSTEP
!
!* 2.3 Cumul of the sources
!
CASE('CC')
PBURVAR(:,:,:,2)=CART_COMPRESS(PVARS)
!
! advance the process counter
!
NBUCTR_ACTV(KBUDN) = NBUCTR_ACTV(KBUDN) &
+ NBUINC(KBUDN,NBUCTR_ACTV(KBUDN))
!
!* 2.4 Difference in order to compute the budget
! for the process NBUPROCCTR
!
CASE('DD')
PBURVAR(:,:,:,NBUPROCCTR(KBUDN))= PBURVAR(:,:,:,NBUPROCCTR(KBUDN)) &
+ CART_COMPRESS(PVARS) &
- PBURVAR(:,:,:,2)
NBUPROCCTR(KBUDN)=NBUPROCCTR(KBUDN)+1
!
! advance the process counter
!
NBUCTR_ACTV(KBUDN) = NBUCTR_ACTV(KBUDN) &
+ NBUINC(KBUDN,NBUCTR_ACTV(KBUDN))
!
!* 2.5 Difference in order to compute the budget for the
! process NBUPROCCTR and Cumul of the sources (NBUPROCCTR=2)
!
CASE('DC')
PBURVAR(:,:,:,NBUPROCCTR(KBUDN)) = PBURVAR(:,:,:,NBUPROCCTR(KBUDN))&
+ CART_COMPRESS(PVARS) &
- PBURVAR(:,:,:,2)
PBURVAR(:,:,:,2)=CART_COMPRESS(PVARS)
NBUPROCCTR(KBUDN)=NBUPROCCTR(KBUDN)+1
!
! advance the process counter
!
NBUCTR_ACTV(KBUDN) = NBUCTR_ACTV(KBUDN) &
+ NBUINC(KBUDN,NBUCTR_ACTV(KBUDN))
CASE('NO')
!
! advance the process counter
!
NBUCTR_ACTV(KBUDN) = NBUCTR_ACTV(KBUDN) &
+ NBUINC(KBUDN,NBUCTR_ACTV(KBUDN))
CASE('OF')
!
! advance the process counter
!
NBUCTR_ACTV(KBUDN) = NBUCTR_ACTV(KBUDN) &
+ NBUINC(KBUDN,NBUCTR_ACTV(KBUDN))
RETURN
END SELECT
!
!* 3. "MASK" CASE
! -----------
!
CASE ('MASK')
!
SELECT CASE (CBUACTION(KBUDN,NBUCTR_ACTV(KBUDN)))
!
!* 3.1 Budget beginning : initial fields
! filled in budget tabulars (NBUPROC=1)
!
CASE('IG')
PBURVAR(:,NBUTIME,:,1) = MASK_COMPRESS(PVARS)
!
!* 3.2 average tendancy filled every time
! step in budget tabulars (NBUPROCCTR=3)
!
CASE('ES')
PBURVAR(:,NBUTIME,:,3) = PBURVAR(:,NBUTIME,:,3) &
+ MASK_COMPRESS(PVARS)/NBUSTEP
!
!* 3.3 Cumul of the sources
!
CASE('CC')
PBURVAR(:,NBUTIME,:,2)=MASK_COMPRESS(PVARS)
!
! advance the process counter
!
NBUCTR_ACTV(KBUDN) = NBUCTR_ACTV(KBUDN) &
+ NBUINC(KBUDN,NBUCTR_ACTV(KBUDN))
!
!* 3.4 Difference in order to compute the budget
! for the process NBUPROCCTR
!
CASE('DD')
PBURVAR(:,NBUTIME,:,NBUPROCCTR(KBUDN)) &
= PBURVAR(:,NBUTIME,:,NBUPROCCTR(KBUDN)) &
+ MASK_COMPRESS(PVARS) &
- PBURVAR(:,NBUTIME,:,2)
NBUPROCCTR(KBUDN)=NBUPROCCTR(KBUDN)+1
!
! advance the process counter
!
NBUCTR_ACTV(KBUDN) = NBUCTR_ACTV(KBUDN) &
+ NBUINC(KBUDN,NBUCTR_ACTV(KBUDN))
!
!* 3.5 Difference in order to compute the budget for the
! process NBUPROCCTR and Cumul of the sources (NBUPROCCTR=2)
!
CASE('DC')
PBURVAR(:,NBUTIME,:,NBUPROCCTR(KBUDN)) &
= PBURVAR(:,NBUTIME,:,NBUPROCCTR(KBUDN)) &
+MASK_COMPRESS(PVARS) &
-PBURVAR(:,NBUTIME,:,2)
PBURVAR(:,NBUTIME,:,2)=MASK_COMPRESS(PVARS)
NBUPROCCTR(KBUDN)=NBUPROCCTR(KBUDN)+1
!
! advance the process counter
!
NBUCTR_ACTV(KBUDN) = NBUCTR_ACTV(KBUDN) &
+ NBUINC(KBUDN,NBUCTR_ACTV(KBUDN))
CASE('NO')
!
! advance the process counter
!
NBUCTR_ACTV(KBUDN) = NBUCTR_ACTV(KBUDN) &
+ NBUINC(KBUDN,NBUCTR_ACTV(KBUDN))
CASE('OF')
!
! advance the process counter
!
NBUCTR_ACTV(KBUDN) = NBUCTR_ACTV(KBUDN) &
+ NBUINC(KBUDN,NBUCTR_ACTV(KBUDN))
RETURN
END SELECT
END SELECT
!
END SUBROUTINE BUDGET_CASE
!
!-------------------------------------------------------------------------------
!
!
END SUBROUTINE BUDGET