Philippe 23/02/2016: lfi2cdf: modif for JPHEXT/=1
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / mesonh / write_diachro.f90
1 !     ######spl
2       MODULE MODI_WRITE_DIACHRO
3 !     #########################
4 !
5 INTERFACE
6 !
7 SUBROUTINE WRITE_DIACHRO(HFILEDIA,HLUOUTDIA,HGROUP,HTYPE,KGRID, &
8                    PDATIME,PVAR,PTRAJT,HTITRE,HUNITE,HCOMMENT,  &
9                    OICP, OJCP, OKCP, KIL, KIH, KJL, KJH, KKL, KKH, &
10                                PTRAJX,PTRAJY,PTRAJZ,PMASK)
11 CHARACTER(LEN=*)              :: HFILEDIA,HLUOUTDIA
12 CHARACTER(LEN=*)              :: HGROUP, HTYPE
13 CHARACTER(LEN=*),DIMENSION(:) :: HTITRE, HUNITE, HCOMMENT
14
15 INTEGER,DIMENSION(:)  :: KGRID
16 INTEGER,OPTIONAL      :: KIL, KIH
17 INTEGER,OPTIONAL      :: KJL, KJH
18 INTEGER,OPTIONAL      :: KKL, KKH
19 LOGICAL,OPTIONAL      :: OICP, OJCP, OKCP
20 REAL,DIMENSION(:,:,:,:,:,:),OPTIONAL  :: PMASK
21 REAL,DIMENSION(:,:)             :: PDATIME
22 REAL,DIMENSION(:,:,:,:,:,:)     :: PVAR
23 REAL,DIMENSION(:,:)             :: PTRAJT
24 REAL,DIMENSION(:,:,:),OPTIONAL  :: PTRAJX
25 REAL,DIMENSION(:,:,:),OPTIONAL  :: PTRAJY
26 REAL,DIMENSION(:,:,:),OPTIONAL  :: PTRAJZ
27
28 END SUBROUTINE WRITE_DIACHRO
29 !
30 END INTERFACE
31 !
32 END MODULE MODI_WRITE_DIACHRO
33 !     ##################################################################
34       SUBROUTINE WRITE_DIACHRO(HFILEDIA,HLUOUTDIA,HGROUP,HTYPE,  &
35       KGRID,PDATIME,PVAR,PTRAJT, &
36       HTITRE,HUNITE,HCOMMENT,OICP,OJCP,OKCP,KIL,KIH,KJL,KJH,KKL,KKH, &
37       PTRAJX,PTRAJY,PTRAJZ,PMASK)
38 !     ##################################################################
39 !
40 !!****  *WRITE_DIACHRO* - Ecriture d'un enregistrement dans un fichier
41 !!                        diachronique (de nom de base HGROUP)
42 !!
43 !!    PURPOSE
44 !!    -------
45 !      
46 !
47 !!**  METHOD
48 !!    ------
49 !!      En fait pour un groupe donne HGROUP, on ecrit systematiquement
50 !       plusieurs enregistrements :
51 !       - 1: HGROUP.TYPE          (type d'informations a enregistrer)
52 !       - 2: HGROUP.DIM           (dimensions de toutes les matrices a 
53 !                                  enregistrer)
54 !       - 3: HGROUP.TITRE         (Nom des processus)
55 !       - 4: HGROUP.UNITE         (Unites pour chaque processus)
56 !       - 5: HGROUP.COMMENT       (Champ commentaire pour chaque processus)
57 !       - 6: HGROUP.TRAJT         (Temps)
58 !       - 7: HGROUP.PROCx         (Champ traite . 1 enr./ 1 processus)
59 !       - 8: HGROUP.DATIM         (Les differentes dates du modele)
60 !       et pour certains types d'informations on enregistre egalement
61 !       des coordonnees (HGROUP.TRAJX, HGROUP.TRAJY, HGROUP.TRAJZ)
62 !!
63 !!    EXTERNAL
64 !!    --------
65 !!      None
66 !!
67 !!    IMPLICIT ARGUMENTS
68 !!    ------------------
69 !!      Module
70 !!
71 !!    REFERENCE
72 !!    ---------
73 !!
74 !!
75 !!    AUTHOR
76 !!    ------
77 !!      J. Duron    * Laboratoire d'Aerologie *
78 !!
79 !!
80 !!    MODIFICATIONS
81 !!    -------------
82 !!      Original       08/01/96
83 !!      Updated   PM 
84 !-------------------------------------------------------------------------------
85 !
86 !*       0.    DECLARATIONS
87 !              ------------
88 !
89 USE MODI_MENU_DIACHRO
90 !USE MODD_BUDGET
91 USE MODI_FMWRIT 
92
93 IMPLICIT NONE
94 !
95 !*       0.1   Dummy arguments
96 !              ---------------
97
98 CHARACTER(LEN=*)              :: HFILEDIA,HLUOUTDIA
99 CHARACTER(LEN=*)              :: HGROUP, HTYPE
100 CHARACTER(LEN=*),DIMENSION(:) :: HTITRE, HUNITE, HCOMMENT
101
102 INTEGER,DIMENSION(:)  :: KGRID
103 INTEGER,OPTIONAL      :: KIL, KIH
104 INTEGER,OPTIONAL      :: KJL, KJH
105 INTEGER,OPTIONAL      :: KKL, KKH
106 LOGICAL,OPTIONAL      :: OICP, OJCP, OKCP
107 REAL,DIMENSION(:,:,:,:,:,:),OPTIONAL  :: PMASK
108 REAL,DIMENSION(:,:,:,:,:,:)     :: PVAR
109 REAL,DIMENSION(:,:)             :: PDATIME
110 REAL,DIMENSION(:,:)             :: PTRAJT
111 REAL,DIMENSION(:,:,:),OPTIONAL  :: PTRAJX
112 REAL,DIMENSION(:,:,:),OPTIONAL  :: PTRAJY
113 REAL,DIMENSION(:,:,:),OPTIONAL  :: PTRAJZ
114
115 !
116 !*       0.1   Local variables
117 !              ---------------
118
119 !
120 CHARACTER(LEN=16) :: YRECFM
121 CHARACTER(LEN=LEN(HFILEDIA)+4) :: YFILEDIA
122 CHARACTER(LEN=20) :: YCOMMENT
123 CHARACTER(LEN=2)  :: YJ
124 INTEGER   ::   ILENG, ILENCH, ILENTITRE, ILENUNITE, ILENCOMMENT, ILE, IRESP
125 INTEGER   ::   ILUOUTDIA, IRESPDIA,INPRARDIA,IFTYPEDIA,IVERBDIA,ININARDIA
126 INTEGER   ::   II, IJ, IK, IT, IN, IP, INUM, J, JJ, JM
127 INTEGER   ::   INTRAJT, IKTRAJX, IKTRAJY, IKTRAJZ
128 INTEGER   ::   ITTRAJX, ITTRAJY, ITTRAJZ
129 INTEGER   ::   INTRAJX, INTRAJY, INTRAJZ
130 INTEGER   ::   IIMASK, IJMASK, IKMASK, ITMASK, INMASK, IPMASK
131 INTEGER   ::   ICOMPX, ICOMPY, ICOMPZ
132 INTEGER,DIMENSION(:),ALLOCATABLE :: ITABCHAR
133 !------------------------------------------------------------------------------
134 !
135 YCOMMENT=' '
136 ILENCH = LEN(YCOMMENT)
137
138 II = SIZE(PVAR,1) ; IT = SIZE(PVAR,4)
139 IJ = SIZE(PVAR,2) ; IN = SIZE(PVAR,5)
140 IK = SIZE(PVAR,3) ; IP = SIZE(PVAR,6)
141
142 INTRAJT=SIZE(PTRAJT,2)
143
144 IKTRAJX=0; IKTRAJY=0; IKTRAJZ=0
145 ITTRAJX=0; ITTRAJY=0; ITTRAJZ=0
146 INTRAJX=0; INTRAJY=0; INTRAJZ=0
147 IF(PRESENT(PTRAJX))THEN
148   IKTRAJX=SIZE(PTRAJX,1)
149   ITTRAJX=SIZE(PTRAJX,2)
150   INTRAJX=SIZE(PTRAJX,3)
151 ENDIF
152 IF(PRESENT(PTRAJY))THEN
153   IKTRAJY=SIZE(PTRAJY,1)
154   ITTRAJY=SIZE(PTRAJY,2)
155   INTRAJY=SIZE(PTRAJY,3)
156 ENDIF
157 IF(PRESENT(PTRAJZ))THEN
158   IKTRAJZ=SIZE(PTRAJZ,1)
159   ITTRAJZ=SIZE(PTRAJZ,2)
160   INTRAJZ=SIZE(PTRAJZ,3)
161 ENDIF
162
163 IIMASK=0; IJMASK=0; IKMASK=0; ITMASK=0; INMASK=0; IPMASK=0
164 IF(PRESENT(PMASK))THEN
165   IIMASK=SIZE(PMASK,1)
166   IJMASK=SIZE(PMASK,2)
167   IKMASK=SIZE(PMASK,3)
168   ITMASK=SIZE(PMASK,4)
169   INMASK=SIZE(PMASK,5)
170   IPMASK=SIZE(PMASK,6)
171 ENDIF
172
173 ILENTITRE = LEN(HTITRE)
174 ILENUNITE = LEN(HUNITE)
175 ILENCOMMENT = LEN(HCOMMENT)
176
177 ICOMPX=0; ICOMPY=0; ICOMPZ=0
178 IF(PRESENT(OICP))THEN
179 IF(OICP)THEN
180   ICOMPX=1
181 ENDIF
182 IF(OJCP)THEN
183   ICOMPY=1
184 ENDIF
185 IF(OKCP)THEN
186   ICOMPZ=1
187 ENDIF
188 ENDIF
189 CALL FMLOOK(HLUOUTDIA,HLUOUTDIA,ILUOUTDIA,IRESP)
190 WRITE(ILUOUTDIA,*)' WRITE_DIACHRO IRESP ',IRESP
191 IF(IRESP == -54)THEN
192   CALL FMATTR(HLUOUTDIA,HLUOUTDIA,ILUOUTDIA,IRESPDIA)
193   OPEN(UNIT=ILUOUTDIA,FILE=HLUOUTDIA)
194   IFTYPEDIA = 0; IVERBDIA = 5
195 ENDIF
196 YFILEDIA=ADJUSTL(ADJUSTR(HFILEDIA)//'.lfi')
197 CALL FMLOOK(YFILEDIA,HLUOUTDIA,INUM,IRESPDIA)
198 WRITE(ILUOUTDIA,*)' WRITE_DIACHRO IRESPDIA ',IRESPDIA
199 IF(IRESPDIA == -54)THEN
200 ! Modif demandee par Nicole Asencio. 28/9/98
201   IFTYPEDIA=2
202   CALL FMOPEN(HFILEDIA,'NEW',HLUOUTDIA,INPRARDIA,IFTYPEDIA,IVERBDIA, &
203   ININARDIA,IRESPDIA)
204 END IF
205
206 !
207 ! 1er enregistrement TYPE
208 !
209 YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TYPE')
210 ILENG = LEN(HTYPE)
211 ALLOCATE(ITABCHAR(ILENG))
212 DO J = 1,ILENG
213   ITABCHAR(J) = ICHAR(HTYPE(J:J))
214 ENDDO
215 !print *,SIZE(ITABCHAR),'  ITABCHAR ',ITABCHAR,' KGRID ',KGRID,HLUOUTDIA,HFILEDIA
216 CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,  &
217 ITABCHAR,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
218 WRITE(ILUOUTDIA,*)' 1er ENREGISTREMENT OK'
219 DEALLOCATE(ITABCHAR)
220 !
221 ! 2eme  enregistrement DIMENSIONS des MATRICES et LONGUEUR des TABLEAUX de CARACTERES et FLAGS de COMPRESSION sur les DIFFERENTS AXES
222 !
223 YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.DIM')
224 SELECT CASE(HTYPE)
225   CASE('CART','MASK','SPXY')
226     ILENG = 34
227     ALLOCATE(ITABCHAR(ILENG))
228     ITABCHAR(1)=ILENTITRE; ITABCHAR(2)=ILENUNITE
229     ITABCHAR(3)=ILENCOMMENT; ITABCHAR(4)=II
230     ITABCHAR(5)=IJ; ITABCHAR(6)=IK
231     ITABCHAR(7)=IT; ITABCHAR(8)=IN
232     ITABCHAR(9)=IP; ITABCHAR(10)=KIL
233     ITABCHAR(11)=KJL; ITABCHAR(12)=KKL
234     ITABCHAR(13)=KIH; ITABCHAR(14)=KJH
235     ITABCHAR(15)=KKH; ITABCHAR(16)=ICOMPX
236     ITABCHAR(17)=ICOMPY; ITABCHAR(18)=ICOMPZ
237     IF(HTYPE == 'MASK')THEN
238 !     ITABCHAR(10)=1; ITABCHAR(11)=1
239 !     ITABCHAR(13)=1; ITABCHAR(14)=1
240       ITABCHAR(16)=1; ITABCHAR(17)=1
241     ENDIF
242     ITABCHAR(19)=INTRAJT; ITABCHAR(20)=IKTRAJX
243     ITABCHAR(21)=IKTRAJY; ITABCHAR(22)=IKTRAJZ
244     ITABCHAR(23)=ITTRAJX; ITABCHAR(24)=ITTRAJY
245     ITABCHAR(25)=ITTRAJZ; ITABCHAR(26)=INTRAJX
246     ITABCHAR(27)=INTRAJY; ITABCHAR(28)=INTRAJZ
247     ITABCHAR(29)=IIMASK; ITABCHAR(30)=IJMASK
248     ITABCHAR(31)=IKMASK; ITABCHAR(32)=ITMASK
249     ITABCHAR(33)=INMASK; ITABCHAR(34)=IPMASK
250     CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
251     KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
252     WRITE(ILUOUTDIA,*)' ILENTITRE,ILENUNITE,ILENCOMMENT ',ILENTITRE,ILENUNITE,ILENCOMMENT
253     DEALLOCATE(ITABCHAR)
254   CASE DEFAULT
255     ILENG = 25 
256     ALLOCATE(ITABCHAR(ILENG))
257     ITABCHAR(1)=ILENTITRE; ITABCHAR(2)=ILENUNITE
258     ITABCHAR(3)=ILENCOMMENT; ITABCHAR(4)=II
259     ITABCHAR(5)=IJ; ITABCHAR(6)=IK
260     ITABCHAR(7)=IT; ITABCHAR(8)=IN
261     ITABCHAR(9)=IP
262     ITABCHAR(10)=INTRAJT; ITABCHAR(11)=IKTRAJX
263     ITABCHAR(12)=IKTRAJY; ITABCHAR(13)=IKTRAJZ
264     ITABCHAR(14)=ITTRAJX; ITABCHAR(15)=ITTRAJY
265     ITABCHAR(16)=ITTRAJZ; ITABCHAR(17)=INTRAJX
266     ITABCHAR(18)=INTRAJY; ITABCHAR(19)=INTRAJZ
267     ITABCHAR(20)=IIMASK; ITABCHAR(21)=IJMASK
268     ITABCHAR(22)=IKMASK; ITABCHAR(23)=ITMASK
269     ITABCHAR(24)=INMASK; ITABCHAR(25)=IPMASK
270 !   CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ILENTITRE,ILENUNITE, &
271 !   ILENCOMMENT,II,IJ,IK,IT,IN,IP,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
272     CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
273     KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
274     DEALLOCATE(ITABCHAR)
275 END SELECT
276 WRITE(ILUOUTDIA,*)' 2eme ENREGISTREMENT OK'
277 !
278 ! 3eme enregistrement TITRE
279 !
280 YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TITRE')
281 ILE = LEN(HTITRE)
282 ILENG = ILE*IP
283 ALLOCATE(ITABCHAR(ILENG))
284 DO JJ = 1,IP
285 DO J = 1,ILE
286   ITABCHAR(ILE*(JJ-1)+J) = ICHAR(HTITRE(JJ)(J:J))
287 ENDDO
288 WRITE(ILUOUTDIA,*)HTITRE(JJ)
289 ENDDO
290 CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,  &
291 ITABCHAR,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
292 WRITE(ILUOUTDIA,*)' 3eme ENREGISTREMENT OK'
293 DEALLOCATE(ITABCHAR)
294 !
295 ! 4eme enregistrement UNITE
296 !
297 YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.UNITE')
298 ILE = LEN(HUNITE)
299 ILENG = ILE*IP
300 ALLOCATE(ITABCHAR(ILENG))
301 DO JJ = 1,IP
302 DO J = 1,ILE
303   ITABCHAR(ILE*(JJ-1)+J) = ICHAR(HUNITE(JJ)(J:J))
304 ENDDO
305 WRITE(ILUOUTDIA,*)HUNITE(JJ)
306 ENDDO
307 CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,  &
308 ITABCHAR,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
309 WRITE(ILUOUTDIA,*)' 4eme ENREGISTREMENT OK'
310 DEALLOCATE(ITABCHAR)
311 !
312 ! 5eme enregistrement COMMENT
313 !
314 YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.COMMENT')
315 ILE = LEN(HCOMMENT)
316 ILENG = ILE*IP
317 ALLOCATE(ITABCHAR(ILENG))
318 DO JJ = 1,IP
319 DO J = 1,ILE
320   ITABCHAR(ILE*(JJ-1)+J) = ICHAR(HCOMMENT(JJ)(J:J))
321 ENDDO
322 WRITE(ILUOUTDIA,*)HCOMMENT(JJ)
323 ENDDO
324 CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,  &
325 ITABCHAR,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
326 WRITE(ILUOUTDIA,*)' 5eme ENREGISTREMENT OK'
327 DEALLOCATE(ITABCHAR)
328 !
329 ! 6eme enregistrement PVAR
330 !
331 ! Dans la mesure ou cette matrice risque d'etre tres volumineuse, on ecrira un 
332 ! enregistrement par processus
333 DO J = 1,IP
334 YJ = '  '
335 IF(J < 10)WRITE(YJ,'(I1)')J ; YJ = ADJUSTL(YJ)
336 IF(J >= 10 .AND. J < 100)WRITE(YJ,'(I2)')J
337 YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.PROC'//YJ)
338 ILENG = II*IJ*IK*IT*IN
339 CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,  &
340             PVAR(:,:,:,:,:,J),KGRID(J),ILENCH,YCOMMENT,IRESPDIA)
341 WRITE(ILUOUTDIA,*)' 6eme ENREGISTREMENT OK'
342 ENDDO
343 !
344 ! 7eme enregistrement TRAJT
345 !
346 YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJT')
347 ILENG = IT*INTRAJT
348 CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,  &
349 PTRAJT,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
350 !
351 ! Dans certains cas
352 !
353 !
354 ! 8eme enregistrement TRAJX
355 !
356 IF(PRESENT(PTRAJX))THEN
357   YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJX')
358   ILENG = IKTRAJX*ITTRAJX*INTRAJX
359   CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,  &
360   PTRAJX,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
361 ENDIF
362 !
363 !                        ou
364 !
365 IF(PRESENT(PMASK))THEN
366   YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.MASK')
367   ILENG = IIMASK*IJMASK*IKMASK*ITMASK*INMASK*IPMASK
368   CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,  &
369   PMASK,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
370 ENDIF
371 !
372 ! 9eme enregistrement TRAJY
373 !
374 IF(PRESENT(PTRAJY))THEN
375   YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJY')
376   ILENG = IKTRAJY*ITTRAJY*INTRAJY
377   CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,  &
378   PTRAJY,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
379 ENDIF
380 !
381 ! 10eme enregistrement TRAJZ
382 !
383 IF(PRESENT(PTRAJZ))THEN
384   YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJZ')
385   ILENG = IKTRAJZ*ITTRAJZ*INTRAJZ
386   CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,  &
387   PTRAJZ,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
388 ENDIF
389 !
390 ! 11eme enregistrement PDATIME
391 !
392 YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.DATIM')
393 ILENG=16*IT
394 CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,  &
395 PDATIME,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
396 !
397 CALL MENU_DIACHRO(HFILEDIA,HLUOUTDIA,HGROUP)
398 !-----------------------------------------------------------------------------
399 !
400 !*       2.       EXITS
401 !                 -----
402
403 RETURN
404 END SUBROUTINE WRITE_DIACHRO