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