Juan 8/12/2016: add management of LEN_HREC in MNH & SURFEX
[MNH-git_open_source-lfs.git] / src / SURFEX / writesurf_ch_emisn.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 WRITESURF_CH_EMIS_n(HPROGRAM)
7 !     ##########################################################
8 !
9 !!****  *WRITESURF_CH_EMIS_n* - routine to write chemistry emission fields
10 !!
11 !!    PURPOSE
12 !!    -------
13 !!
14 !!    AUTHOR
15 !!    ------
16 !!      V. Masson   *Meteo France*      
17 !!
18 !!    MODIFICATIONS
19 !!    -------------
20 !!      Original    03/2004
21 !!      M.Moge    01/2016  using WRITE_SURF_FIELD2D/3D for 2D/3D surfex fields writes
22 !-------------------------------------------------------------------------------
23 !
24 !*       0.    DECLARATIONS
25 !              ------------
26 !
27 USE MODD_CH_EMIS_FIELD_n,ONLY : NEMIS_NBR, CEMIS_AREA, CEMIS_NAME, &
28                                   CEMIS_COMMENT, NEMIS_TIME, XEMIS_FIELDS  
29 USE MODI_WRITE_SURF
30 USE MODI_WRITE_SURF_FIELD2D
31 !
32 !
33 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
34 USE PARKIND1  ,ONLY : JPRB
35 !
36 USE MODI_ABOR1_SFX
37 !
38 IMPLICIT NONE
39 !
40 !*       0.1   Declarations of arguments
41 !              -------------------------
42 !
43  CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
44 !
45 !*       0.2   Declarations of local variables
46 !              -------------------------------
47 !
48 INTEGER           :: IRESP          ! IRESP  : return-code if a problem appears 
49                                     ! at the open of the file in LFI  routines 
50 !
51  CHARACTER(LEN=LEN_HREC) :: YRECFM         ! Name of the article to be written
52  CHARACTER(LEN=100):: YCOMMENT       ! Comment string
53  CHARACTER(LEN=100):: YCOMMENTUNIT   ! Comment string : unit of the datas in the field to write
54  CHARACTER(LEN=80) :: YNAME          ! emitted species name
55 !
56 INTEGER           :: JI,JT          ! loop indices
57 INTEGER           :: JSPEC          ! loop index
58 LOGICAL           :: GFOUND,LOK
59  CHARACTER(LEN=40),DIMENSION(NEMIS_NBR) :: YEMISPEC_NAMES
60 INTEGER,          DIMENSION(NEMIS_NBR) :: INBTIMES
61 INTEGER,          DIMENSION(NEMIS_NBR) :: IFIRST,ILAST,INEXT
62 INTEGER :: INTIMESMAX,ITMP
63 INTEGER :: IEMISPEC_NBR
64 REAL(KIND=JPRB) :: ZHOOK_HANDLE
65
66 !-------------------------------------------------------------------------------
67 !
68 !*       1.     Chemical Emission fields :
69 !               --------------------------
70 !
71 IF (LHOOK) CALL DR_HOOK('WRITESURF_CH_EMIS_N',0,ZHOOK_HANDLE)
72 YRECFM='EMISFILE_NBR'
73 YCOMMENT='Total number of 2D emission files.'
74  CALL WRITE_SURF(HPROGRAM,YRECFM,NEMIS_NBR,IRESP,HCOMMENT=YCOMMENT)
75 !
76 ! count emitted species 
77 IEMISPEC_NBR = 0
78 DO JI=1,NEMIS_NBR
79   YNAME = TRIM(ADJUSTL(CEMIS_NAME(JI)))
80   GFOUND = .FALSE.
81   DO JSPEC = 1,IEMISPEC_NBR
82     IF (YEMISPEC_NAMES(JSPEC) == YNAME) THEN
83       GFOUND = .TRUE.
84       EXIT
85     END IF
86   END DO
87   IF (.NOT. GFOUND) THEN
88     IEMISPEC_NBR = IEMISPEC_NBR+1
89     YEMISPEC_NAMES(IEMISPEC_NBR) = YNAME
90     INBTIMES(IEMISPEC_NBR) = 1
91     IFIRST(IEMISPEC_NBR) = JI
92     ILAST(IEMISPEC_NBR)  = JI
93     INEXT(JI) = 0
94   ELSE
95     INEXT(ILAST(JSPEC)) = JI
96     INEXT(JI)        = 0
97     ILAST(JSPEC)        = JI
98     INBTIMES(JSPEC) = INBTIMES(JSPEC)+1
99   END IF
100 END DO
101 !
102 YRECFM='EMISPEC_NBR '
103 YCOMMENT='Number of emitted chemical species.'
104  CALL WRITE_SURF(HPROGRAM,YRECFM,IEMISPEC_NBR,IRESP,HCOMMENT=YCOMMENT)
105 !
106 IF (IEMISPEC_NBR > 0) THEN
107   !
108   DO JSPEC = 1,IEMISPEC_NBR
109     CALL WRITE_EMIS_SPEC(INBTIMES(JSPEC))
110   ENDDO
111   !
112 ENDIF
113 !
114 IF (LHOOK) CALL DR_HOOK('WRITESURF_CH_EMIS_N',1,ZHOOK_HANDLE)
115 !
116 !-------------------------------------------------------------------------------
117 CONTAINS
118 !
119 SUBROUTINE WRITE_EMIS_SPEC(KSIZE)
120 !
121 INTEGER, INTENT(IN) :: KSIZE
122 INTEGER,DIMENSION(KSIZE) :: ITIME
123 INTEGER,DIMENSION(KSIZE) :: IINDEX
124 REAL,DIMENSION(SIZE(XEMIS_FIELDS,1),KSIZE) :: ZWORK2D
125 REAL(KIND=JPRB) :: ZHOOK_HANDLE
126 !
127 IF (LHOOK) CALL DR_HOOK('WRITESURF_CH_EMIS_N:WRITE_EMIS_SPEC',0,ZHOOK_HANDLE)
128 !
129 JI = IFIRST(JSPEC)
130 JT = 0
131 ! fill the emission times array (ITIME)
132 ! and the corresponding indices array (IINDEX)
133 ! for species number JSPEC
134 DO WHILE(JI /= 0)
135   JT = JT+1
136   ITIME(JT)  = NEMIS_TIME(JI)
137   IINDEX(JT) = JI
138   JI = INEXT(JI)
139 END DO
140 IF (JT /= KSIZE) THEN
141   CALL ABOR1_SFX('WRITESURF_CH_EMISN: ABNORMAL ERROR')
142 END IF
143 ! sort indices according to ITIME values
144 LOK = .TRUE.
145 DO WHILE (LOK)
146   LOK = .FALSE.
147   DO JI=2,KSIZE
148     IF (ITIME(JI-1) > ITIME(JI)) THEN
149       LOK = .TRUE.
150       ITMP = ITIME(JI-1)
151       ITIME(JI-1) = ITIME(JI)
152       ITIME(JI)   = ITMP
153       ITMP = IINDEX(JI-1)
154       IINDEX(JI-1) = IINDEX(JI)
155       IINDEX(JI)   = ITMP
156     END IF
157   END DO
158 END DO
159 ! Now fill the ZWORK2D array for writing
160 ZWORK2D(:,:) = XEMIS_FIELDS(:,IINDEX(:))
161
162 ! Write NAME of species JSPEC with AREA and number of emission times 
163 ! stored in the commentary
164 WRITE(YRECFM,'("EMISNAME",I3.3)') JSPEC
165 WRITE(YCOMMENT,'(A3,", emission times number:",I5)') CEMIS_AREA(IINDEX(1)),KSIZE
166  CALL WRITE_SURF(HPROGRAM,YRECFM,YEMISPEC_NAMES(JSPEC),IRESP,HCOMMENT=YCOMMENT)
167
168 ! Write emission times (ITIME) for species JSPEC
169 WRITE(YRECFM,'("EMISTIMES",I3.3)') JSPEC  
170 YCOMMENT = "Emission times in second"
171  CALL WRITE_SURF(HPROGRAM,YRECFM,ITIME(:),IRESP,HCOMMENT=YCOMMENT,HDIR='-')
172 !
173 ! Finally write emission data for species JSPEC
174 YRECFM = "E_"//TRIM(YEMISPEC_NAMES(JSPEC))
175 YCOMMENT = "Emission data (x,y,t),"//TRIM(CEMIS_COMMENT(IINDEX(1)))
176 YCOMMENTUNIT='-'
177 CALL WRITE_SURF_FIELD2D(HPROGRAM,ZWORK2D(:,:),YRECFM,YCOMMENT,YCOMMENTUNIT)
178 !
179 IF (LHOOK) CALL DR_HOOK('WRITESURF_CH_EMIS_N:WRITE_EMIS_SPEC',1,ZHOOK_HANDLE)
180 !
181 END SUBROUTINE WRITE_EMIS_SPEC
182 !
183 END SUBROUTINE WRITESURF_CH_EMIS_n