Philippe 02/05/2016: moved all LIBTOOLS files in LIBTOOLS directory
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / EXTRACTDIA / writevar.f90
1 !     #################################
2       MODULE MODI_WRITEVAR
3 !     #################################
4 INTERFACE WRITEVAR
5       SUBROUTINE  WRITEVAR(kideb,kifin,kjdeb,kjfin,kkdeb,kkfin,&
6        ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin,  &
7        HLABELCHAMP,HFILENAME,HFLAGFILE,HFILENAME_SUP,KVERBIA,KRETCODE)
8 !
9 CHARACTER(LEN=*), INTENT(IN) :: HLABELCHAMP, HFILENAME ! nom du champ et du fichier
10 CHARACTER(LEN=3), INTENT(IN) :: HFLAGFILE              ! NEW=creation 
11                                                        ! OLD=ajout 
12                                                        ! CLO=fermeture
13 CHARACTER(LEN=3)             :: HFILENAME_SUP          ! chaine de caracteres
14                                                        ! a rajouter a
15                                                        ! HFILENAME
16                                                        ! si ='NEN' alors HFILENAME
17                                                        ! contient le nom complet
18 INTEGER , INTENT(IN)         :: KVERBIA                ! prints de controle
19 !
20 INTEGER , intent(in)         :: kideb,kifin,kjdeb,kjfin,kkdeb,kkfin   
21 INTEGER , intent(in)         :: ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin
22 !
23 INTEGER  , INTENT(OUT)       :: KRETCODE  ! Code de retour de la routine 
24 !
25 END SUBROUTINE
26 END INTERFACE
27 END MODULE MODI_WRITEVAR
28 !     ######
29       SUBROUTINE  WRITEVAR(kideb,kifin,kjdeb,kjfin,kkdeb,kkfin,&
30        ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin, &
31        HLABELCHAMP,HFILENAME,HFLAGFILE,HFILENAME_SUP,KVERBIA,KRETCODE)
32 !     ################
33 !
34 !!****  *WRITEVAR* - 
35 !! 
36 !!
37 !!    PURPOSE
38 !!    -------
39 !     Ecriture d'un fichier  de type:
40 !       diachronique en vue d'un traitement via diaprog
41
42 !
43 !!**  METHOD
44 !!    ------
45 !     utilisation des routines de diaprog : le tableau de stockage
46 !     XVAR est alloué avant l appel a WRITEVAR
47 !
48 !     HFLAGFILE='NEW' lors de la premiere utilisation du fichier
49 !     HFLAGFILE='OLD' lors des utilisations suivantes
50 !     HFLAGFILE='CLO' pour la fermeture du fichier de sortie
51 !      ( fin de mise a jour du menu )
52 !
53 !     KVERBIA= 0 impressions reduites au minimum (entree et sortie de la
54 !      routine)
55 !     KVERBIA >0 impressions pour signaler chaque etape de WRITEVAR
56 !
57 !     KRETCODE = 0 execution de WRITEVAR correcte
58 !     KRETCODE = 1 erreur lors de l ouverture du fichier
59 !     KRETCODE = 2 erreur lors de l ecriture du champ 
60 !     KRETCODE = 3 erreur lors de la fermeture du champ 
61 !     KRETCODE = -1 pas de fermeture car pas d ouverture
62 !
63 !     kideb,kifin,kjdeb,kjfin,kkdeb,kkfin = limites en indices i,j,k du
64 !       domaine à traiter dans XVAR       
65 !     ktdeb,ktfin,ktrdeb,ktrfin = limites en indices
66 !       des dimensions 4,5 de XVAR  
67 !
68 !!    EXTERNAL
69 !!    --------
70 !!          FROM_COMPUTING_UNITS: retour aux unites initiales  avant ecriture
71 !!                               = passage inverse a celui realise par
72 !!                                 TO_COMPUTING_UNITS
73 !!                              
74 !!
75 !!    IMPLICIT ARGUMENTS
76 !!    ------------------
77 !!
78 !!    REFERENCE
79 !!    ---------
80 !!
81 !!    AUTHORS
82 !!    -------
83 !!    I. Mallet , N. Asencio , J. Stein * CNRM*
84 !!
85 !!    Copyright 2003,  Meteo-France and Laboratoire d'Aerologie
86 !!    All Rights Reserved
87 !!
88 !!    MODIFICATIONS
89 !!    -------------
90 !!      Original    17/03/2003
91 !       N. Asencio  01/2005 : take in account 2D fields XZ, YZ and
92 !                             zoomed fields inside the complete x-y-z-grid
93 !
94 !-------------------------------------------------------------------------------
95 !
96 !*       0.    DECLARATIONS
97 !              ------------
98 !
99 ! modules MESONH
100 USE MODD_CST
101 USE MODD_PARAMETERS, ONLY: JPHEXT,JPVEXT
102 !                    NIMAX,NJMAX,NKMAX,NIINF, NISUP
103 USE MODD_DIM1
104 USE MODD_GRID, ONLY: XLAT0,XLON0,XRPK,XBETA
105 !                    descriptif grille: XXHAT(:) ,XLAT(:,:),XDXHAT(:),XMAP(:,:)
106 !                    ,XZS(:,:),XZZ(:,:,:) ,XCOSSLOPE(:,:),XDIRCOSXW(:,:)
107 USE MODD_GRID1
108 !      
109 ! modules DIACHRO
110 USE MODN_NCAR,  ONLY: XSPVAL    
111 USE MODD_COORD ! grille : XXDXHAT(:,1:7) et XXX(:,1:7), XXZS(:,:,1:7)
112 USE MODD_TYPE_AND_LH ! zoom selon x et y et z :  NIL,NIH,NJL,NJH,NKL,NKH,CTYPE
113 USE MODD_ALLOC_FORDIACHRO ! XVAR(i,j,k,,,), XMASK,XTRAJ ,XDATIME(16,t)   
114 USE MODD_OUT ! nom de fichiers NLUOUT,CLFIFM, CDESFM
115 USE MODD_FILES_DIACHRO ! NBFILES + nom des fichiers CFILEDIAS, CLUOUTDIAS
116 !                    pour l appel a WRITE_DIMGRIDREF, FMATTR et FMCLOS
117 USE MODD_DIACHRO, ONLY:CFILEDIA,CLUOUTDIA, &
118                        NLUOUTDIA,NRESPDIA,NNPRARDIA,NFTYPEDIA,NVERBDIA,NNINARDIA
119 USE MODD_READLH
120 !
121 USE MODI_WRITE_DIMGRIDREF      
122 USE MODI_WRITE_DIACHRO      
123 USE MODI_MENU_DIACHRO
124 USE MODI_FROM_COMPUTING_UNITS
125
126 !
127 IMPLICIT NONE
128 !
129 !*       0.1   Arguments d'appel
130 !              ----------------
131 !
132 CHARACTER(LEN=*), INTENT(IN) :: HLABELCHAMP, HFILENAME ! nom du champ et du fichier
133 CHARACTER(LEN=3), INTENT(IN) :: HFLAGFILE              ! NEW=creation 
134                                                        ! OLD=ajout 
135                                                        ! CLO=fermeture
136 CHARACTER(LEN=3)             :: HFILENAME_SUP          ! chaine de caracteres
137                                                        !a rajouter a HFILENAME
138                                                        ! si ='NEN' alors HFILENAME
139                                                        ! contient le nom complet
140 INTEGER , INTENT(IN)         :: KVERBIA                ! prints de controle
141 !
142 INTEGER , intent(in)         :: kideb,kifin,kjdeb,kjfin,kkdeb,kkfin   
143 INTEGER , intent(in)         :: ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin
144 !
145 INTEGER , INTENT(OUT)        :: KRETCODE  ! Code de retour de la routine 
146 !
147 !*       0.2   Declarations des variables locales
148 !              -----------------------------------
149 !
150 INTEGER           ::  ISAVENGRIDIA,iret
151 !                 repositionne le zoom/grille si zoom d un champ deja zoome
152 INTEGER          :: InewIL,InewIH,InewJL,InewJH,InewKL,InewKH
153 !
154 REAL ,DIMENSION(:,:,:,:,:,:) , ALLOCATABLE :: ZVARZS,& ! stockage dans
155                                                        ! un tableau 6d de ZS 
156                                                        ! avant son ecriture
157                                               ZVARSAVE ! sauvegarde de XVAR
158 !
159 ! taille=100  et 28 cf diachro 
160 CHARACTER (LEN=100) :: YSAVETITRE, YSAVECOMMENT, YSAVEUNITE 
161 CHARACTER (LEN=28), SAVE  :: YFILEOUT='zadefinir'        ! Fichier de sortie
162 CHARACTER (LEN=28)  :: YSAVEFILEDIA             ! sauve le contenu de CFILEDIA 
163 CHARACTER (LEN=3)   :: YFLAGZS 
164 CHARACTER (LEN=3)   :: YFLAGFILE 
165 !
166 INTEGER,SAVE   ::   IGROUP=0  ! pour compter le nb de champs ecrits
167 !-------------------------------------------------------------------------------
168 !
169 !*       1.    INITIALISATION
170 !              --------------
171 !      
172 ! Code de retour de la routine : 0 = OK
173 !                                1 = erreur lors de l ouverture du fichier
174 KRETCODE=0
175 !
176 YFLAGFILE=HFLAGFILE
177 !
178 if (KVERBIA >= 0) then
179   print *,'--------- '
180   print *,'Beginning of WRITEVAR ',TRIM(HFILENAME),' ',TRIM(HLABELCHAMP),' ',&
181                              TRIM(YFLAGFILE)  ,' ',&
182                              TRIM(HFILENAME_SUP),' ',KVERBIA
183 endif
184 !
185 ! code de retour d erreur des routines diaprog
186 LPBREAD=.FALSE.                                                        
187 !
188 !*       1.1    Determine le nom du fichier de sortie au premier passage
189 !              -------------------
190 !
191 IF (YFILEOUT=='zadefinir') THEN
192   ! alignement à droite pour que le test LEN(YFILEOUT)-1:LEN(YFILEOUT)) == '.Z' fonctionne
193   YFILEOUT=(ADJUSTR(HFILENAME))
194   IF (HFILENAME_SUP(1:3) /= 'NEN' ) THEN
195   ! cas d un appel obs2mesonh 
196   !avec redefinition totale du nom de fichier de sortie (on prend HFILENAME tel quel)
197     IF (HFILENAME_SUP(1:3)=='SAM') THEN
198     ! cas d un appel dans compute_r00pc
199      ! pas d ajout de suffixe (on complete un fichier existant ouvert en 'OLD')
200      ! m.a.j. de la liste des enregistrements diachroniques
201       CALL MENU_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),'READ')
202       IF(YFLAGFILE(1:3)/='CLO') YFLAGFILE='OLD'
203     ELSE
204       ! ajout d un suffixe 2
205       IF (LEN_TRIM(HFILENAME_SUP) == 0) HFILENAME_SUP='2  '
206       !  
207       IF ( YFILEOUT(LEN(YFILEOUT)-1:LEN(YFILEOUT)) == '.Z' ) THEN
208         ! ajout du suffixe devant le .Z
209         ! et suppression de .Z car le fichier cree sera non compresse
210         YFILEOUT=ADJUSTL(YFILEOUT(1:LEN(YFILEOUT)-2)//HFILENAME_SUP)
211       ELSE
212         ! ajout en fin de nom 
213         YFILEOUT=ADJUSTL(YFILEOUT(1:LEN(YFILEOUT))//HFILENAME_SUP)
214       END IF
215     END IF
216   ENDIF
217   YFILEOUT=ADJUSTL(YFILEOUT)
218 END IF
219 !    
220 if (KVERBIA > 0) then
221   PRINT*,'WRITEVAR: output diachronic file ',YFILEOUT
222 endif
223
224 !*       1.2    Appel avec fichier courant different du fichier a ecrire
225 !              -------------------
226 !          cas possibles dans compute_r00pc, exrwdia et obs2mesonh avec HFILENAME_SUP(1:3) /= 'NEN'
227 !
228 IF ( YFLAGFILE(1:3) /= 'CLO'  ) THEN      
229 !   reinit eventuelle de l entete si fichier courant different du fichier a ecrire
230   YSAVEFILEDIA=CFILEDIA
231   IF ( YSAVEFILEDIA /= HFILENAME  .AND. HFILENAME_SUP(1:3) /= 'NEN' ) THEN
232    ! seul le cas compute_r00pc est concerné
233    ! dans le cas  obs2mesonh avec HFILENAME_SUP(1:3) /= 'NEN', la reinit de 
234    ! l entete  (date et heure) a été  faite dans obs2mesonh
235     if (KVERBIA > 0) then
236       print *,'WRITEVAR: fichier courant dans READVAR ',YSAVEFILEDIA
237       print *,' different du fichier a ecrire ', HFILENAME
238       print *,' seul XVAR est sauve. La grille spatiale est supposée identique.'
239     endif
240     ISAVENGRIDIA=NGRIDIA(1)
241     YSAVETITRE=CTITRE(1)
242     YSAVECOMMENT=CCOMMENT(1)
243     YSAVEUNITE=CUNITE(1)
244     ! lecture d un champ de HFILENAME pour reinitialiser les modules diachro
245     !pour creer l en tete du fichier de sortie YFILEOUT(HFILENAME)
246     ALLOCATE(ZVARSAVE(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
247                       SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6)) )
248     ZVARSAVE=XVAR
249     YFLAGZS='NOP'
250     CALL READVAR ('ZSBIS',HFILENAME,YFLAGZS,KVERBIA,iret)
251     if (KVERBIA > 0) then
252       print *,'WRITEVAR: apres reinit des modules pour le fichier ',HFILENAME
253     endif
254     DEALLOCATE(XVAR)
255     ALLOCATE(XVAR(SIZE(ZVARSAVE,1),SIZE(ZVARSAVE,2),SIZE(ZVARSAVE,3),&
256                   SIZE(ZVARSAVE,4),SIZE(ZVARSAVE,5),SIZE(ZVARSAVE,6)) )
257     XVAR=ZVARSAVE
258     NGRIDIA(1)=ISAVENGRIDIA
259     CTITRE(1)=YSAVETITRE            
260     CCOMMENT(1)=YSAVECOMMENT
261     CUNITE(1)=YSAVEUNITE            
262   ENDIF
263   CFILEDIA=ADJUSTL(YFILEOUT)
264 ENDIF
265 !      
266 !-------------------------------------------------------------------------------
267 !
268 !*       2.    Ouverture du fichier de sortie
269 !              -------------------
270 !      
271 IF ( YFLAGFILE(1:3) /= 'CLO' ) THEN
272 ! Repositionne eventuellement le zoom  en I et J , pour K (2 cas)
273 InewIL=max(NREADIL,kideb)
274 InewJL=max(NREADJL,kjdeb)
275 InewKL=max(NREADKL,kkdeb)
276 InewIH=min(NREADIH,kifin)
277 InewJH=min(NREADJH,kjfin)
278 InewKH=min(NREADKH,kkfin)
279 IF ( NREADKL == NREADKH .AND. SIZE(XVAR,3) > 1 )THEN
280    ! en lecture le tableau contient un seul niveau vertical
281    ! en ecriture le tableau (autre variable) contient plusieurs niveaux: 
282    ! ecriture du zoom utilisateur
283    InewKL=kkdeb
284    InewKH=kkfin
285    print *, '* warning: desaccord sur le zoom selon la verticale'
286    print *, ' le zoom lu=',NREADKL,NREADKH ,'et le zoom ecrit=',kkdeb,kkfin
287    ! Pour des traces diaprog sur ce nouveau zoom
288    NREADKL=kkdeb
289    NREADKH=kkfin
290 ENDIF
291   if (KVERBIA > 1) then
292     print*,'ancienne localisation du champ/grille :',NREADIL,NREADIH,NREADJL,NREADJH,NREADKL,NREADKH
293     print*,' zoom demande: ', kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
294     print*,'nouvelle localisation du champ/grille :',&
295              InewIL,InewIH,InewJL,InewJH,InewKL,InewKH
296   endif
297 ENDIF
298 !      
299 IF ( YFLAGFILE(1:3) == 'NEW' ) THEN
300   !
301   CLUOUTDIA=CLUOUTDIAS(NBFILES)
302   NLUOUTDIA=NLUOUTDIAS(NBFILES)
303   if (KVERBIA >0)then
304       print *,'WRITEVAR: avant OPEN_FILES ',TRIM(YFILEOUT),' ',TRIM(CFILEDIA), &
305                                             ' ',TRIM(CLUOUTDIA)
306   endif
307   !
308   if (KVERBIA > 1) then
309     print *,'WRITEVAR: lat0,lon0 ',XLAT0,XLON0
310   endif
311   !      Ouverture et ecriture de l entete
312   CALL WRITE_DIMGRIDREF
313   IF (NRESPDIA.NE.0)THEN
314     KRETCODE=1
315     print *,' ****WRITEVAR: erreur lors de l ouverture du fichier ',&
316             YFILEOUT, 'code= ',NRESPDIA
317     RETURN
318   ENDIF 
319   !
320   IF (TRIM(HLABELCHAMP)/='ZSBIS') THEN
321   ! Ecriture de ZS avec le nom ZSBIS necessaire pour tracer
322   !  le champ "ZS" dans diaprog
323     ALLOCATE(ZVARZS(SIZE(XZS,1),SIZE(XZS,2),1,1,1,1))
324     ZVARZS(:,:,1,1,1,1)=XZS
325     ISAVENGRIDIA=NGRIDIA(1)
326     YSAVETITRE=CTITRE(1)
327     YSAVECOMMENT=CCOMMENT(1)
328     YSAVEUNITE=CUNITE(1)
329     NGRIDIA(1)=4
330     CTITRE(1)='ZSBIS'
331     CUNITE(1)='m'
332     CCOMMENT(1)='X_Y_ZS (m)' 
333     CALL WRITE_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),'ZSBIS','CART',NGRIDIA,&
334                        XDATIME,ZVARZS(kideb:kifin,kjdeb:kjfin,:,:,:,:),&
335                        XTRAJT,CTITRE,CUNITE,CCOMMENT, &
336                        .FALSE.,.FALSE.,.FALSE.,InewIL,InewIH,InewJL,InewJH,1,1)
337     if (KVERBIA > 0) then
338       print *,'WRITEVAR(zs) size= 1:',size(ZVARZS,1),',1:',size(ZVARZS,2)
339       print *,'  InewIL,InewIH,InewJL,InewJH,1,1=', InewIL,InewIH,InewJL,InewJH
340     end if
341     DEALLOCATE(ZVARZS)
342     NGRIDIA(1)=ISAVENGRIDIA
343     CTITRE(1)=YSAVETITRE
344     CCOMMENT(1)=YSAVECOMMENT
345     CUNITE(1)=YSAVEUNITE                   
346     if (KVERBIA > 1) then
347       print *,'WRITEVAR: apres write_diachro ZSBIS'
348     endif
349   !
350     IF (NRESPDIA.NE.0)THEN
351       KRETCODE=2
352       print *,' ****WRITEVAR: erreur lors de l ecriture de ZS  dans ',&
353             YFILEOUT, ' code= ',NRESPDIA
354       RETURN
355     ELSE 
356       IGROUP=IGROUP+1
357     ENDIF 
358   !
359   ENDIF 
360 !
361 ENDIF
362 !
363 !-------------------------------------------------------------------------------
364 !
365 !*       4     Ecriture du champ dans YFILEOUT
366 !              -------------------
367 !
368 IF ( YFLAGFILE(1:3) /= 'CLO' ) THEN
369   !
370   if (KVERBIA >= 0) then
371     print*,'WRITEVAR: ecriture en cours de ',HLABELCHAMP
372   endif
373   !  Retour aux unites initiales si necessaire
374   CALL FROM_COMPUTING_UNITS(HLABELCHAMP,CUNITE(1)) 
375   !
376   if (KVERBIA > 1) then
377     print*,'WRITEVAR: NGRID,NGRIDIA(:) =',NGRID,NGRIDIA
378   endif
379   !
380   IF ( SIZE(XVAR,6) /= SIZE(NGRIDIA,1))THEN
381     print * ,' *** erreur possible: la dimension6 de XVAR=',SIZE(XVAR,6) ,&
382              'est differente de la dimension des tableaux NGRIDIA,CUNIT...'
383   ENDIF
384   IF ( SIZE(XVAR,4) /= SIZE(XDATIME,2))THEN
385     print * ,' *** erreur possible: la dimension4 de XVAR=',SIZE(XVAR,4) ,&
386              'est differente de la dimension des tableaux XDATIME,XTRAJT...'
387   ENDIF
388   !
389   IF (ALLOCATED(XMASK)) THEN
390     ! CTYPE='MASK'
391     IF ( SIZE(XVAR,5) /= SIZE(XMASK,5))THEN
392       print * ,' *** erreur possible: la dimension5 de XVAR=',SIZE(XVAR,5) ,&
393                'est differente de la dimension5 du tableau XMASK'
394     ENDIF
395     CALL WRITE_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),HLABELCHAMP,CTYPE,   &
396                        NGRIDIA(kpdeb:kpfin),XDATIME(:,ktdeb:ktfin),     &
397                        XVAR(kideb:kifin,kjdeb:kjfin,kkdeb:kkfin,& 
398                             ktdeb:ktfin,ktrdeb:ktrfin,kpdeb:kpfin),&
399                        XTRAJT(ktdeb:ktfin,:),CTITRE(kpdeb:kpfin),&
400                        CUNITE(kpdeb:kpfin),CCOMMENT(kpdeb:kpfin), &
401                        LICP,LJCP,LKCP,InewIL,InewIH,InewJL,InewJH,InewKL,InewKH,&
402    !                   LICP,LJCP,LKCP,kideb,kifin,kjdeb,kjfin,kkdeb,kkfin,&
403                        PMASK=XMASK)
404   ELSE IF (ALLOCATED(XTRAJX).AND.ALLOCATED(XTRAJY).AND.ALLOCATED(XTRAJZ))THEN
405     IF ( CTYPE=='SSOL' ) THEN
406       CALL WRITE_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),HLABELCHAMP,CTYPE,   &
407                        NGRIDIA(kpdeb:kpfin),XDATIME(:,ktdeb:ktfin),  &
408                        XVAR(kideb:kifin,kjdeb:kjfin,kkdeb:kkfin,& 
409                             ktdeb:ktfin,ktrdeb:ktrfin,kpdeb:kpfin),&
410                        XTRAJT(ktdeb:ktfin,:),CTITRE(kpdeb:kpfin),&
411                        CUNITE(kpdeb:kpfin),CCOMMENT(kpdeb:kpfin), &
412                        PTRAJX=XTRAJX,PTRAJY=XTRAJY,               &
413                        PTRAJZ=XTRAJZ(kkdeb:kkfin,1:1,ktrdeb:ktrfin))
414     ELSE
415     ! CTYPE='DRST' or CTYPE='RSPL' or CTYPE='RAPL'
416       CALL WRITE_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),HLABELCHAMP,CTYPE,   &
417                        NGRIDIA(kpdeb:kpfin),XDATIME(:,ktdeb:ktfin),  &
418                        XVAR(kideb:kifin,kjdeb:kjfin,kkdeb:kkfin,& 
419                             ktdeb:ktfin,ktrdeb:ktrfin,kpdeb:kpfin),&
420                        XTRAJT(ktdeb:ktfin,:),CTITRE(kpdeb:kpfin),&
421                        CUNITE(kpdeb:kpfin),CCOMMENT(kpdeb:kpfin), &
422                        PTRAJX=XTRAJX,PTRAJY=XTRAJY,               &
423                        PTRAJZ=XTRAJZ(kkdeb:kkfin,ktdeb:ktfin,ktrdeb:ktrfin))
424     ENDIF
425   ELSE IF (.NOT.ALLOCATED(XTRAJX) .AND. .NOT.ALLOCATED(XTRAJY) .AND. .NOT.ALLOCATED(XTRAJZ))THEN
426     ! CTYPE='CART' or CTYPE='SPXY'
427     CALL WRITE_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),HLABELCHAMP,CTYPE,   &
428                        NGRIDIA(kpdeb:kpfin),XDATIME(:,ktdeb:ktfin),      &
429                        XVAR(kideb:kifin,kjdeb:kjfin,kkdeb:kkfin,& 
430                             ktdeb:ktfin,ktrdeb:ktrfin,kpdeb:kpfin),&
431                        XTRAJT(ktdeb:ktfin,:),CTITRE(kpdeb:kpfin),&
432                        CUNITE(kpdeb:kpfin),CCOMMENT(kpdeb:kpfin), &
433                        LICP,LJCP,LKCP,InewIL,InewIH,InewJL,InewJH,InewKL,InewKH)
434     !                  LICP,LJCP,LKCP,kideb,kifin,kjdeb,kjfin,kkdeb,kkfin)
435   ELSE
436     KRETCODE=2
437     print *,' ****WRITEVAR: cas d ecriture non prevu pour ',HLABELCHAMP
438     RETURN
439   ENDIF 
440   if (KVERBIA > 0) then
441     print *,'WRITEVAR(champ)'
442     print *,'  ideb,ifin,jdeb,jfin,kdeb,kfin=', &
443         kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
444     print *,'  tdeb,tfin,trdeb,trfin,pdeb,pfin=',&
445         ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin
446   end if
447   if (KVERBIA > 1) then
448     print*,'WRITEVAR: apres write_diachro, CTYPE=',CTYPE,' xdatime(16,ktdeb:ktfin)'
449     do iret=ktdeb,ktfin
450      print*, iret,' ',XDATIME(1:4,iret)
451      print*, XDATIME(5:8,iret)
452      print*, XDATIME(9:12,iret)
453      print*, XDATIME(13:16,iret)
454     end do
455   endif
456   IF (NRESPDIA.NE.0)THEN
457     KRETCODE=2
458     print *,' ****WRITEVAR: erreur lors de l ecriture de ',HLABELCHAMP,&
459             ' dans ',YFILEOUT, ' code= ',NRESPDIA
460     RETURN
461   ELSE 
462     IGROUP=IGROUP+1
463   ENDIF 
464   !
465   CFILEDIA=YSAVEFILEDIA
466   IF ( YSAVEFILEDIA /= HFILENAME .AND. HFILENAME_SUP(1:3) /= 'NEN') THEN
467     ! retablit les infos du fichier courant
468     if (KVERBIA > 0) then
469       print *,'WRITEVAR: avant retour aux infos des modules pour ',&
470               ' le fichier courant ', YSAVEFILEDIA
471     endif
472     !      
473     YFLAGZS='NOP'
474     CALL READVAR ('ZSBIS',YSAVEFILEDIA,YFLAGZS,KVERBIA,iret)
475     DEALLOCATE(XVAR)
476     ALLOCATE(XVAR(SIZE(ZVARSAVE,1),SIZE(ZVARSAVE,2),SIZE(ZVARSAVE,3),&
477              SIZE(ZVARSAVE,4),SIZE(ZVARSAVE,5),SIZE(ZVARSAVE,6)) )
478     XVAR=ZVARSAVE
479     DEALLOCATE(ZVARSAVE)
480   ENDIF
481   if (KVERBIA >= 0) then
482     print *,'--------- '
483   endif
484   !
485 ENDIF
486 !
487 !-------------------------------------------------------------------------------
488 !
489 !*       4     FERMETURE  des fichiers de sortie
490 !              ---------------------------------
491 !
492 IF ( YFLAGFILE(1:3) == 'CLO' ) THEN
493   if (KVERBIA > 0 .AND. IGROUP>0) then
494     print *,'WRITEVAR: before closing the output file ',TRIM(YFILEOUT)
495     print *,' List of the ',IGROUP,' variables :'
496   endif
497   !
498   ! fichier de sortie
499   CALL MENU_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),'END')
500   if (KVERBIA > 0 .AND. IGROUP>0) then
501     CALL MENU_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),'READ')
502   endif
503   IF (IGROUP>0) THEN
504     CALL FMCLOS(YFILEOUT,'KEEP',CLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
505     !           
506     if (NRESPDIAS(NBFILES)==0) then
507       print*,'End of WRITEVAR: file ',TRIM(YFILEOUT),' available '
508       print *,'--------- '
509     else
510       print *,' ****WRITEVAR: error when closing the file ',&
511               TRIM(YFILEOUT), ' code= ',NRESPDIAS(NBFILES)
512       KRETCODE=3
513     endif
514   ELSE
515     print *,' ****WRITEVAR: file not opened, so no closing'
516     KRETCODE=-1
517   END IF
518   ! pour determination du nom du fichier de sortie au prochain appel
519   YFILEOUT='zadefinir'
520   IGROUP=0
521   !
522 ENDIF
523 !
524 END SUBROUTINE WRITEVAR