Juan 13/01/2014: add header SURFEX_LIC to all SURFEX files
[MNH-git_open_source-lfs.git] / src / SURFEX / build_pronoslistn.F90
1 !SURFEX_LIC Copyright 1994-2014 Meteo-France 
2 !SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
3 !SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
4 !SURFEX_LIC for details. version 1.
5 !     #########
6       SUBROUTINE BUILD_PRONOSLIST_n(KEMIS_NBR,HEMIS_NAME,TPPRONOS,KCH,KLUOUT,KVERB)
7 !!    #######################################################################
8 !!
9 !!*** *BUILD_PRONOSLIST*
10 !!
11 !!    PURPOSE
12 !!    -------
13 !!
14 !!
15 !!**  METHOD
16 !!    ------
17 !!
18 !!
19 !!    AUTHOR
20 !!    ------
21 !!    D. Gazen
22 !!
23 !!    MODIFICATIONS
24 !!    -------------
25 !!    Original 01/02/00
26 !!    C. Mari  30/10/00 call to MODD_TYPE_EFUTIL
27 !!    D. Gazen 01/12/03 change emissions handling for surf. externalization
28 !!    P. Tulet 01/05/05 aerosols primary emission
29 !!
30 !!    EXTERNAL
31 !!    --------
32 USE MODI_CH_OPEN_INPUTB
33 !!
34 !!    IMPLICIT ARGUMENTS
35 !!    ------------------
36 USE MODD_TYPE_EFUTIL
37 USE MODD_SV_n,  ONLY: CSV
38 !------------------------------------------------------------------------------
39 !
40 !*       0.   DECLARATIONS
41 !        -----------------
42 !
43 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
44 USE PARKIND1  ,ONLY : JPRB
45 !
46 USE MODI_ABOR1_SFX
47 !
48 IMPLICIT NONE
49 !
50 !*       0.1  declaration of arguments
51 !
52 INTEGER,                       INTENT(IN)  :: KEMIS_NBR ! number of emitted species
53  CHARACTER(LEN=6), DIMENSION(KEMIS_NBR), INTENT(IN) :: HEMIS_NAME ! name of emitted species
54 TYPE(PRONOSVAR_T),             POINTER     :: TPPRONOS
55 INTEGER,                       INTENT(IN)  :: KCH     ! logical unit of input chemistry file
56 INTEGER,                       INTENT(IN)  :: KLUOUT  ! output listing channel
57 INTEGER,                       INTENT(IN)  :: KVERB   ! verbose level
58 !
59 !*       0.2  declaration of local variables
60 !
61  CHARACTER(LEN=256) :: YINPLINE ! input agregation line read from Namelist
62 INTEGER :: INDX     ! 
63 INTEGER :: INBCOEFF ! Numer of agregations coeff for one species
64 INTEGER :: JI       ! loop index
65 INTEGER :: INDX_PRO ! index of the pronostic variable in CNAMES array
66 INTEGER :: IERR
67  CHARACTER(LEN=32) :: YPRO_NAME, YEMIS_NAME ! Name of the pronostic & emission species
68 LOGICAL :: GFOUND
69  CHARACTER(LEN=6), DIMENSION(:),POINTER :: CNAMES
70 TYPE(PRONOSVAR_T),             POINTER :: HEAD,CURRENT
71 INTEGER :: IEQ
72 REAL(KIND=JPRB) :: ZHOOK_HANDLE
73 !
74 !------------------------------------------------------------------------------
75 !
76 !*    EXECUTABLE STATEMENTS
77 !     ---------------------
78 !
79 IF (LHOOK) CALL DR_HOOK('BUILD_PRONOSLIST_N',0,ZHOOK_HANDLE)
80 !
81 !
82 ! CNAMES points on chemical variables name
83 CNAMES => CSV
84 IEQ = SIZE(CSV)
85 !
86 ! Namelist is opened and the agregation eq. are reached
87 !
88  CALL CH_OPEN_INPUTB("AGREGATION", KCH , KLUOUT)
89 !
90 ! Parse each eq. line and build the TPPRONOS list
91 !
92 NULLIFY(HEAD)
93 NULLIFY(CURRENT)
94 DO 
95 !
96 ! Read a line and convert 'tab' to 'space' characters
97 ! until the keyword 'END_AGREGATION' is reached
98   READ(KCH,'(A)',IOSTAT=IERR) YINPLINE
99   IF (IERR /= 0) EXIT
100   YINPLINE = TRIM(ADJUSTL(YINPLINE))
101   IF (LEN_TRIM(YINPLINE) == 0) CYCLE ! skip blank line
102   IF (YINPLINE == 'END_AGREGATION') EXIT
103   CALL TAB2SPACE(YINPLINE)
104 !
105 !
106 !Extract pronostic variable name
107   INDX = INDEX(YINPLINE,' ')
108   YPRO_NAME = YINPLINE(1:INDX-1)
109 !
110 ! search the variable in CNAMES, STOP if not FOUND
111   GFOUND = .FALSE.
112   DO JI=1,IEQ
113     IF (CNAMES(JI) == YPRO_NAME) THEN 
114       INDX_PRO = JI
115       GFOUND = .TRUE.
116       EXIT
117     END IF
118   END DO
119   IF (.NOT. GFOUND) THEN
120     WRITE(KLUOUT,*) 'BUILD_PRONOSLIST ERROR : ',TRIM(YPRO_NAME),&
121             ' not found in pronostic variables list !'  
122     CALL ABOR1_SFX('CH_BUILDPRONOSN: VARIABLE NOT FOUND')
123   END IF
124 !
125 ! If YPRO_NAME variable already encountered : append the new equation (coeffs)
126   GFOUND = .FALSE.
127   INBCOEFF = 0
128   CURRENT=>HEAD
129   DO WHILE(ASSOCIATED(CURRENT))
130     IF (CURRENT%NAMINDEX == INDX_PRO) THEN
131       INBCOEFF = CURRENT%NBCOEFF
132       GFOUND   = .TRUE.
133       EXIT
134     END IF
135     CURRENT=>CURRENT%NEXT
136   END DO
137   IF (.NOT. GFOUND) THEN
138 !   New pronostic cell is created
139     ALLOCATE(CURRENT)
140     CURRENT%NAMINDEX = INDX_PRO
141     CURRENT%NEXT     => HEAD
142     HEAD => CURRENT
143   END IF
144 !
145 !
146 ! Extract the agregation coeffs
147   DO
148 ! get REAL coeff
149     YINPLINE = ADJUSTL(YINPLINE(INDX:))
150     INDX = INDEX(YINPLINE,' ')
151     IF (INDX == 1) EXIT
152     INBCOEFF = INBCOEFF+1
153     IF (INBCOEFF > JPNBCOEFFMAX) THEN
154       WRITE(KLUOUT,*) 'FATAL ERROR : Number of aggregation coefficients for ',&
155              TRIM(YPRO_NAME),' exceeds constant JPNBCOEFFMAX = ',JPNBCOEFFMAX  
156       WRITE(KLUOUT,*) '=> You should increase the JPNBCOEFFMAX value in modd_type_efutil.f90'
157       CALL ABOR1_SFX('CH_BUILDPRONOSN: NUMBER OF AGGREGATION COEFFICIENTS TOO BIG')
158     END IF
159     READ(YINPLINE(1:INDX-1),*) CURRENT%XCOEFF(INBCOEFF)
160 !
161 ! get EMIS species name
162     YINPLINE = ADJUSTL(YINPLINE(INDX:))
163     INDX = INDEX(YINPLINE,' ')
164     YEMIS_NAME = YINPLINE(1:INDX-1)
165 !
166 ! check EMIS species name
167     GFOUND = .FALSE.
168     DO JI=1,KEMIS_NBR
169       IF (HEMIS_NAME(JI) == YEMIS_NAME) THEN
170         GFOUND = .TRUE.
171         CURRENT%NEFINDEX(INBCOEFF) = JI
172         EXIT
173       END IF
174     END DO
175     IF (.NOT. GFOUND) THEN
176       WRITE(KLUOUT,*) 'ERROR : ',TRIM(YEMIS_NAME),&
177               ' not found in emission variables list !'  
178       CALL ABOR1_SFX('CH_BUILDPRONOSN: UNKNOWN EMISSION VARIABLE')
179     END IF
180   END DO
181   CURRENT%NBCOEFF = INBCOEFF
182 END DO
183
184 !
185 ! Update TPPRONOS pointer with head of list
186 TPPRONOS => HEAD
187 !
188 IF (KVERB >= 6) THEN
189   WRITE(KLUOUT,*) 'BUILD_PRONOSLIST: Aggregation results'
190   CURRENT=>HEAD
191   DO WHILE(ASSOCIATED(CURRENT))
192     WRITE(KLUOUT,*) 'Emission for Atmospheric Chemical Species ',TRIM(CNAMES(CURRENT%NAMINDEX)),' (index ',&
193             CURRENT%NAMINDEX,' in CSV)'  
194     WRITE(KLUOUT,*) 'is aggregated with the following weights from the Emission Inventory Species:'
195     DO JI=1,CURRENT%NBCOEFF
196       WRITE(KLUOUT,*) CURRENT%XCOEFF(JI),HEMIS_NAME(CURRENT%NEFINDEX(JI))
197     END DO
198     CURRENT=>CURRENT%NEXT
199   END DO
200 END IF
201
202 IF (LHOOK) CALL DR_HOOK('BUILD_PRONOSLIST_N',1,ZHOOK_HANDLE)
203 CONTAINS 
204 !!
205 !!    ###########################
206       SUBROUTINE TAB2SPACE(HTEXT)
207 !!    ###########################
208 !!
209 !!*** *TAB2SPACE*
210 !!
211 !!    PURPOSE
212 !!    -------
213 !!     Convert 'tab' character to 'space' character in the string HTEXT
214 !!
215 !!**  METHOD
216 !!    ------
217 !!
218 !!    AUTHOR
219 !!    ------
220 !!    D. Gazen
221 !!
222 !!    MODIFICATIONS
223 !!    -------------
224 !!    Original 01/02/2000
225 !!
226 !!    EXTERNAL
227 !!    --------
228 !!
229 !!    IMPLICIT ARGUMENTS
230 !!    ------------------
231 !------------------------------------------------------------------------------
232 !
233 !*       0.   DECLARATIONS
234 !        -----------------
235 IMPLICIT NONE
236 !
237 !*       0.1  declaration of arguments
238 !
239  CHARACTER(len=*),INTENT(INOUT) :: HTEXT
240 !
241 !*       0.2  declaration of local variables
242 !
243  CHARACTER, PARAMETER :: YPTAB = CHAR(9) ! TAB character is ASCII : 9
244 INTEGER              :: JI
245 REAL(KIND=JPRB) :: ZHOOK_HANDLE
246 !
247 !------------------------------------------------------------------------------
248 !
249 !*    EXECUTABLE STATEMENTS
250 !     ---------------------
251 !
252 IF (LHOOK) CALL DR_HOOK('TAB2SPACE',0,ZHOOK_HANDLE)
253 DO JI=1,LEN_TRIM(HTEXT)
254   IF (HTEXT(JI:JI) == YPTAB) HTEXT(JI:JI) = ' '
255 END DO
256 IF (LHOOK) CALL DR_HOOK('TAB2SPACE',1,ZHOOK_HANDLE)
257 END SUBROUTINE TAB2SPACE
258
259 END SUBROUTINE BUILD_PRONOSLIST_n