Newer
Older
!SURFEX_LIC Copyright 1994-2014 Meteo-France
!SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!SURFEX_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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
! #########
SUBROUTINE AVERAGE1_LDB(KLUOUT,PLAT,PLON,PVALUE,HTYPE)
! #######################################################
!
!!**** *AVERAGE1_LDB*
!!
!! PURPOSE
!! -------
!!
!! METHOD
!! ------
!!
!! EXTERNAL
!! --------
!!
!! IMPLICIT ARGUMENTS
!! ------------------
!!
!!
!! REFERENCE
!! ---------
!!
!! AUTHOR
!! ------
!!
!! S. Faroux Meteo-France
!!
!! MODIFICATION
!! ------------
!!
!! Original 17/02/11
!!
!----------------------------------------------------------------------------
!
!* 0. DECLARATION
! -----------
!
USE MODD_PGDWORK, ONLY : XTNG, NSIZE
USE MODD_DATA_LAKE, ONLY : XBOUNDGRADDEPTH_LDB, XBOUNDGRADSTATUS_LDB
!
USE MODD_POINT_OVERLAY
!
USE MODI_GET_MESH_INDEX
USE MODI_ABOR1_SFX
!
USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
USE PARKIND1 ,ONLY : JPRB
!
IMPLICIT NONE
!
!* 0.1 Declaration of arguments
! ------------------------
!
INTEGER, INTENT(IN) :: KLUOUT
REAL, DIMENSION(:), INTENT(IN) :: PLAT ! latitude of the point to add
REAL, DIMENSION(:), INTENT(IN) :: PLON ! longitude of the point to add
REAL, DIMENSION(:), INTENT(IN) :: PVALUE ! value of the point to add
CHARACTER(LEN=1), INTENT(IN) :: HTYPE
!
!* 0.2 Declaration of other local variables
! ------------------------------------
!
REAL, DIMENSION(:), ALLOCATABLE :: ZBOUND
!
INTEGER, DIMENSION(SIZE(PLAT)) :: IINDEX ! mesh index of all input points
! 0 indicates the point is out of the domain
!
REAL :: ZCUT
INTEGER :: JLOOP, JGRAD ! loop index on input arrays
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!----------------------------------------------------------------------------
!
!
!* 1. Get position
! ------------
!
IF (LHOOK) CALL DR_HOOK('AVERAGE1_LDB',0,ZHOOK_HANDLE)
!
SELECT CASE (HTYPE)
!
CASE('D')
ALLOCATE(ZBOUND(SIZE(XBOUNDGRADDEPTH_LDB)))
ZBOUND(:) = XBOUNDGRADDEPTH_LDB(:)
!
CASE('S')
ALLOCATE(ZBOUND(SIZE(XBOUNDGRADSTATUS_LDB)))
ZBOUND(:) = XBOUNDGRADSTATUS_LDB(:)
!
CASE DEFAULT
CALL ABOR1_SFX("AVERAGE1_LDB: HTYPE NOT SUPPORTED")
!
END SELECT
!
IF (ALLOCATED(XNUM)) DEALLOCATE(XNUM)
ALLOCATE(XNUM(SIZE(PLAT)))
!
XNUM(:)=1
!
DO WHILE(MAXVAL(XNUM).NE.0)
!
CALL GET_MESH_INDEX(KLUOUT,PLAT,PLON,IINDEX)
!
!* 2. Loop on all input data points
! -----------------------------
!
DO JLOOP = 1 , SIZE(PLAT)
!
!* 3. Tests on position
! -----------------
!
IF (IINDEX(JLOOP)==0) CYCLE
!
!* 4. Test on value meaning
! ---------------------
!
ZCUT = PVALUE(JLOOP)
!
DO JGRAD = 1, SIZE(ZBOUND)-1
IF (ZCUT.GT.ZBOUND(JGRAD) .AND. ZCUT.LE.ZBOUND(JGRAD+1)) THEN
XTNG(IINDEX(JLOOP),JGRAD) = XTNG(IINDEX(JLOOP),JGRAD) + 1
EXIT
ENDIF
ENDDO
!
!* 5. Summation
! ---------
!
NSIZE(IINDEX(JLOOP))=NSIZE(IINDEX(JLOOP))+1
!
END DO
ENDDO
!
DEALLOCATE(ZBOUND)
!
IF (LHOOK) CALL DR_HOOK('AVERAGE1_LDB',1,ZHOOK_HANDLE)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE AVERAGE1_LDB