Philippe 02/05/2016: moved all LIBTOOLS files in LIBTOOLS directory
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / FM2DIA / conv2dia.select.f90
1 !     ######spl
2       PROGRAM  FM2DIACHRO
3 !     ###################
4 !
5 !!****  *FM2DIACHRO* -  Conversion des fichiers synchrones LFIFM en
6 !!                      fichiers de type diachronique (LFIFM egalement)
7 !! 
8 !!
9 !!    PURPOSE
10 !!    -------
11
12 !       Convertit 1 (ou plusieurs fichiers synchrones correspondant a
13 !       des sorties successives d'un meme run) en 1 fichier diachronique
14 !
15 !!**  METHOD
16 !!    ------
17 !!      
18 !       La routine LFILAF (du logiciel LFI) modifiee (--> JDLFILAF) pour
19 !       l'ouverture d'un fichier FICJD ecrit dans celui-ci le numero,
20 !       le nom et la longueur totale des enregistrements.
21 !       Puis un appel a la routine LFILEC permet de lire dans le 2eme mot
22 !       de chaque enregistrement la longueur du champ commentaire (qui n'est
23 !       pas necessairement constante) et donc de deduire par soustraction
24 !       la longueur du champ physique enregistre 
25 !       de sorte que l'on possede toutes les informations necessaires a la
26 !       lecture avec FMREAD des enregistrements d'un fichier LFIFM dont on ne 
27 !       connait pas a priori le contenu. (du moins pour les infos reelles)
28 !       Dans un premier temps, on ecrit dans le fichier diachonique avec
29 !       la routine WRITE_LFIFM1_FORDIACHRO_CV l'entete des fichiers d'entree
30 !       en particulier les parametres de grille, l'etat de reference ...
31 !       Puis en bouclant sur le nombre de fichiers a traiter et le nombre
32 !       d'enregistrements de chacun, on lit chaque champ et on regroupe
33 !       progressivement dans un enregistrement du fichier diachronique unique
34 !       pour un meme parametre les differentes echeances trouvees.
35 !       ACTUELLEMENT (Avril 97) SONT PRIS EN COMPTE LES CHAMPS DE LONGUEUR
36 !       IIU*IJU*IKU  , IIU*IJU  et  1
37 !
38 !!
39 !!    REFERENCE
40 !!    ---------
41 !!     
42 !!
43 !!    AUTHORS
44 !!    -------
45 !!    J. Duron      *Lab. Aerologie* 
46 !!
47 !!    Copyright 1994,  Meteo-France and Laboratoire d'Aerologie
48 !!    All Rights Reserved
49 !!
50 !!    MODIFICATIONS
51 !!    -------------
52 !!      Original    30/01/96 
53 !-------------------------------------------------------------------------------
54 !
55 !*       0.    DECLARATIONS
56 !              ------------
57 !
58 USE MODD_CONF          
59 USE MODD_DIM1, ONLY: NIMAX,NJMAX,NKMAX          
60 USE MODD_GRID  ! XLON0,XLAT0, XBETA,XRPK
61 USE MODD_GRID1 ! XLONOR,XLATOR
62 USE MODD_TIME1 ! TDTCUR
63 !
64 USE MODD_DIACHRO
65 USE MODD_OUT_DIA
66 USE MODD_REA_LFI    
67 USE MODD_DIMGRID_FORDIACHRO
68 !USE MODI_READ_DESFM
69 USE MODI_READ_DIMGRIDREF_FM2DIA
70 USE MODI_WRITE_DIMGRIDREF
71 USE MODI_WRITE_OTHERSFIELDS
72 USE MODI_MENU_DIACHRO
73 USE MODI_INI_CST
74
75 IMPLICIT NONE
76 !
77 !*       0.1   Local variables declarations
78 !
79 INTEGER           :: ILUDES    ! Logical unit number for the DES file
80 INTEGER           :: INUMER
81
82 INTEGER,DIMENSION(50) :: IFICJD
83
84 INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE :: IWORK 
85
86 INTEGER           :: INUM, ISIZ, INBM, IKEEP, IOK
87
88 INTEGER           :: IRESP, IVAR
89 INTEGER           :: INEWSIZE, ITYPCOD
90
91 INTEGER           :: JJ, J, JA
92 INTEGER           :: INB, IID, JI, JIP1, ICODEL, IL, IDA
93 INTEGER           :: I4
94 INTEGER,DIMENSION(:), ALLOCATABLE  :: IIMAX, IJMAX, IKMAX
95 REAL,DIMENSION(:), ALLOCATABLE  :: ZTIMECUR,ZLON0,ZRPK,ZLONOR,ZLATOR,ZLAT0,ZBETA
96 LOGICAL,DIMENSION(:), ALLOCATABLE :: OCARTESIAN
97 LOGICAL           :: GDTOUT, GOK
98
99 CHARACTER*16      :: YRECFM, YRECFM2
100 CHARACTER*3       :: YREPON
101 CHARACTER*16      :: YREF
102 CHARACTER*16      :: YCOMMENT
103 CHARACTER*80      :: YCAR80  
104 CHARACTER*16,DIMENSION(50)      :: YFICJD, YFICJDOUT
105 CHARACTER*16,DIMENSION(:), ALLOCATABLE,SAVE :: YRECT, YRECID, YKEEP
106 CHARACTER*16,DIMENSION(4)                   :: YPRI
107
108 !-------------------------------------------------------------------------------
109 !
110 !*       1.    Definition du type de traitement et init du fichier de constantes
111 !              -----------------------------------------------------------------
112 !
113 CPROGRAM='FM2DIA'
114 !
115 CCONF='POSTP'
116 CALL INI_CST
117 OPEN(80,FILE='dirconv.select',FORM='FORMATTED')
118 !
119 !
120 !*       2.    Lecture du nombre de fichiers a regrouper et de leur nom 
121 !              --------------------------------------------------------
122 !              Doivent etre dissocies en *.des et *.lfi et
123 !              rentres en ordre chronologique (1 / 1 ligne)
124 !
125 PRINT *,' ENTER NUMBER OF INPUT FM FILES'
126 READ(5,*)NNBF
127 YCAR80(1:LEN(YCAR80))=' '
128 WRITE(YCAR80,*)NNBF
129 YCAR80=ADJUSTL(YCAR80)
130 WRITE(80,'(A80)')YCAR80
131
132 DO J=1,NNBF
133   PRINT *,' ENTER FM FILE NAME'
134   READ(5,'(A28)')CNAMFILED(J)   
135   YCAR80(1:LEN(YCAR80))=' '
136   YCAR80=CNAMFILED(J)
137   YCAR80=ADJUSTL(YCAR80)
138   WRITE(80,'(A80)')YCAR80
139 ENDDO
140 !
141 !
142 !*       3.    Lecture du nom du fichier diachronique a creer
143 !              ----------------------------------------------
144 !
145
146 PRINT *,' ENTER DIACHRONIC FILE NAME'
147 READ(5,'(A28)')CFILEDIA
148 YCAR80(1:LEN(YCAR80))=' '
149 YCAR80=CFILEDIA     
150 YCAR80=ADJUSTL(YCAR80)
151 WRITE(80,'(A80)')YCAR80
152 !
153 !*       4.    Ouverture du fichier correspondant au listing
154 !              ---------------------------------------------
155 !
156 CLUOUTD='LISTING_DIA'
157 CALL FMATTR(CLUOUTD,CLUOUTD,NLUOUTD,NRESP)
158 OPEN(UNIT=NLUOUTD,FILE=CLUOUTD,FORM='FORMATTED')
159 ! print *,' CLUOUT ',CLUOUTD
160 !
161 !*       5.    Boucle sur les fichiers a lire 
162 !              ------------------------------
163 !
164 DO J=1,NNBF
165
166   CLFIFMD(J)=ADJUSTL(ADJUSTR(CNAMFILED(J))//'.lfi')
167   CDESFMD(J)=ADJUSTL(ADJUSTR(CNAMFILED(J))//'.des')
168
169 !
170 !*       5.1   Ouverture des fichiers LFIFM et DESFM
171 !
172   CSTATU='OLD'
173   NVERB=5
174 ! Modif demandee par Nicole Asencio. 28/9/98
175   NFTYPE=2
176 ! NFTYPE=0
177   CALL FMOPEN(CNAMFILED(J),CSTATU,CLUOUTD,NNPRAR,NFTYPE,NVERB,NNINAR,NRESP)
178   IF(NRESP.NE.0)THEN
179     WRITE(0,*)'BUG OPENING LFIFM FILE ',CLFIFMD(J),'  RETURN CODE= ',NRESP
180   END IF
181 !
182 !*       5.2   Fermeture du fichier DESFM  (ACTUELLEMENT NON INTEGRE DANS LE
183 !                                           FICHIER DIACHRONIQUE)
184 !
185 !  (Contains namelists: Nam_lunitn + Nam_confn 
186 !   + Nam_dynn + Nam_paramn + Nam_conf + Nam_dyn)
187
188   CALL FMLOOK(CDESFMD(J),CDESFMD(J),ILUDES,NRESP)
189   CLOSE(ILUDES)
190 !
191 !*       5.3   Lecture du numero, nom et longueur des enregistrements
192 !              Memorisation dans les tableaux NNUMT,CRECFM2T,NSIZT
193 !
194 !
195   GDTOUT=.TRUE.
196   CALL FMLOOK(CLFIFMD(J),CLUOUTD,INUMER,NRESP)
197   CALL JDLFILAF(NRESP,INUMER,GDTOUT)
198 !
199   YFICJD(J)='FICJD'
200   YFICJDOUT(J)='FICJDOUT'
201   CALL FMATTR(YFICJD(J),YFICJDOUT(J),IFICJD(J),NRESP)
202   OPEN(UNIT=IFICJD(J),FILE=YFICJD(J),FORM='FORMATTED',STATUS='OLD')
203 !
204   NNB=0
205   DO JJ=1,10000
206     READ(IFICJD(J),*,END=99)INUM,YRECFM2,ISIZ
207     NNB=NNB+1
208   ENDDO
209 99 CONTINUE
210
211   IF(J == 1)THEN
212     INBM=NNB
213   ENDIF
214
215   WRITE(NLUOUTD,*)' ******** FICHIER N: ',J,CNAMFILED(J)(1:LEN_TRIM(CNAMFILED(J))), &
216   ' NB ENR. ',NNB
217   WRITE(NLUOUTD,*)' ******** '
218
219   REWIND(IFICJD(J))
220 !
221   IF(J == 1)THEN
222     ALLOCATE(NNUMT(NNB+100,50),NSIZT(NNB+100,50),NLENC(NNB+100,50))
223     ALLOCATE(CRECFM2T(NNB+100,50))
224   ENDIF
225   !
226   DO JJ=1,NNB
227     READ(IFICJD(J),*)NNUMT(JJ,J),CRECFM2T(JJ,J),NSIZT(JJ,J)
228     ALLOCATE(IWORK(NSIZT(JJ,J)))
229     CALL LFILEC(NRESP,INUMER,CRECFM2T(JJ,J),IWORK,NSIZT(JJ,J))
230     NLENC(JJ,J)=IWORK(2)     ! longueur de la zone commentaire
231 ! Determination de la longueur de la zone de donnees
232 ! 2 = 1er mot : numero de grille et 2eme mot : longueur de la zone commentaire
233     NSIZT(JJ,J)=NSIZT(JJ,J)-2-NLENC(JJ,J)
234     CALL GET_COMPHEADER(IWORK(3+NLENC(JJ,J)),NSIZT(JJ,J),INEWSIZE,ITYPCOD)
235     IF (INEWSIZE >= 0) THEN ! compressed field found
236       WRITE (NLUOUTD,*) TRIM(CRECFM2T(JJ,J)),' is compressed (old/new SIZE):',NSIZT(JJ,J),INEWSIZE
237       NSIZT(JJ,J)=INEWSIZE
238     END IF
239     DEALLOCATE(IWORK)
240   ENDDO
241 !
242   CLOSE (IFICJD(J))
243   CALL FMFREE(YFICJD(J),YFICJDOUT(J),NRESP)
244
245 ! Verification de l'egalite du nombre d'enregistrements dans les differents
246 ! fichiers
247
248   IF(J > 1)THEN
249     IF(INBM /= NNB)THEN
250       WRITE(NLUOUTD,*)' ******************************************'
251       WRITE(NLUOUTD,*)' Nb enregistrents different (/ 1er fichier)'
252       WRITE(NLUOUTD,*)' ******************************************'
253       WRITE(NLUOUTD,*)' ( - = absence par rapport au 1er fichier, + = ajout)'
254       WRITE(NLUOUTD,*)' ( + ne sont pas integres dans le fichier diachronique)'
255     ENDIF
256   ENDIF
257
258 ! Verification de l'identite des enregistrements dans les differents fichiers
259
260   IF(J > 1)THEN
261     IF(INBM /= NNB)THEN
262       IF (INBM > NNB)THEN
263         DO JJ=1,INBM
264           GOK=.FALSE.
265           DO JA=1,NNB
266             IF(CRECFM2T(JJ,1) == CRECFM2T(JA,J))THEN
267               GOK=.TRUE.
268               EXIT
269             ELSE
270               CYCLE
271             ENDIF
272           ENDDO
273           IF(.NOT.GOK)THEN
274             NNUMT(JJ,1)=0
275             WRITE(NLUOUTD,*)' -  ',CRECFM2T(JJ,1)
276           ENDIF
277         ENDDO
278
279       ELSE
280
281         DO JJ=1,NNB
282           GOK=.FALSE.
283           DO JA=1,INBM
284             IF(CRECFM2T(JJ,J) == CRECFM2T(JA,1))THEN
285               GOK=.TRUE.
286               EXIT
287             ELSE
288               CYCLE
289             ENDIF
290           ENDDO
291           IF(.NOT.GOK)THEN
292             WRITE(NLUOUTD,*)' +  ',CRECFM2T(JJ,J)
293           ENDIF
294         ENDDO
295       ENDIF
296     ENDIF
297   ENDIF
298   !
299 !
300 !*       5.4   Lecture et ecriture des parametres "intouchables"
301 !
302   CALL READ_DIMGRIDREF_FM2DIA(J,CNAMFILED(J),CLUOUTD)
303 !
304 !        5.41  Writing or checking  DIM., GRID., REF. VARIABLES
305 !
306   IF(J == 1)THEN  ! premier fichier
307     CALL WRITE_DIMGRIDREF
308     ALLOCATE(IIMAX(NNBF),IJMAX(NNBF),IKMAX(NNBF),ZTIMECUR(NNBF))
309     ALLOCATE(ZLON0(NNBF),ZLAT0(NNBF),ZLONOR(NNBF),ZLATOR(NNBF), &
310                                         ZRPK(NNBF),ZBETA(NNBF)  )
311     ALLOCATE(OCARTESIAN(NNBF))
312   ENDIF
313 !
314   IIMAX(J)=NIMAX ; IJMAX(J)=NJMAX ; IKMAX(J)=NKMAX
315   ZTIMECUR(J)=TDTCUR%TIME
316   ZLON0(J)=XLON0   ; ZLAT0(J)=XLAT0
317   ZLONOR(J)=XLONOR ; ZLATOR(J)=XLATOR
318   ZRPK(J)=XRPK     ; ZBETA(J)=XBETA
319   OCARTESIAN(J)=LCARTESIAN
320 !
321   IF(J > 1)THEN   ! fichiers suivants
322   !
323     IF(IIMAX(J) /= IIMAX(1))THEN
324       PRINT *,' J IIMAX(J) IIMAX(1) ',J,IIMAX(J),IIMAX(1)
325     ENDIF
326     IF(IJMAX(J) /= IJMAX(1))THEN
327       PRINT *,' J IJMAX(J) IJMAX(1) ',J,IJMAX(J),IJMAX(1)
328     ENDIF
329     IF(IKMAX(J) /= IKMAX(1))THEN
330       PRINT *,' J IKMAX(J) IKMAX(1) ',J,IKMAX(J),IKMAX(1)
331     ENDIF
332     IF(ZTIMECUR(J) /= ZTIMECUR(1))THEN
333       PRINT *,' J ZTIMECUR(J) ZTIMECUR(1) ',J,ZTIMECUR(J),ZTIMECUR(1)
334     ENDIF
335     IF(ZLON0(J) /= ZLON0(1))THEN
336       PRINT *,' J ZLON0(J) ZLON0(1) ',J,ZLON0(J),ZLON0(1)
337     ENDIF
338     IF(ZRPK(J) /= ZRPK(1))THEN
339       PRINT *,' J ZRPK(J) ZRPK(1) ',J,ZRPK(J),ZRPK(1)
340     ENDIF
341     IF(ZLONOR(J) /= ZLONOR(1))THEN
342       PRINT *,' J ZLONOR(J) ZLONOR(1) ',J,ZLONOR(J),ZLONOR(1)
343     ENDIF
344     IF(ZLATOR(J) /= ZLATOR(1))THEN
345       PRINT *,' J ZLATOR(J) ZLATOR(1) ',J,ZLATOR(J),ZLATOR(1)
346     ENDIF
347     IF(ZLAT0(J) /= ZLAT0(1))THEN
348       PRINT *,' J ZLAT0(J) ZLAT0(1) ',J,ZLAT0(J),ZLAT0(1)
349     ENDIF
350     IF(ZBETA(J) /= ZBETA(1))THEN
351       PRINT *,' J ZBETA(J) ZBETA(1) ',J,ZBETA(J),ZBETA(1)
352     ENDIF
353     IF((OCARTESIAN(J) .AND..NOT. OCARTESIAN(1)) .OR. &
354        (.NOT. OCARTESIAN(J) .AND. OCARTESIAN(1)))THEN
355       PRINT *,' J OCARTESIAN(J) OCARTESIAN(1) ',J,OCARTESIAN(J),OCARTESIAN(1)
356     ENDIF
357     !
358   ENDIF
359 !
360   IF(J == NNBF)THEN  ! dernier fichier
361     DEALLOCATE(IIMAX,IJMAX,IKMAX,ZTIMECUR)
362     DEALLOCATE(ZLON0,ZRPK,ZLONOR,ZLATOR,ZLAT0,ZBETA)
363     DEALLOCATE(OCARTESIAN)
364   END IF
365 !
366 !        5.42  Eventuelle eliminination de certains parametres ds le fic. diach.
367 !
368   IF(J == 1)THEN
369
370
371     ALLOCATE(YRECT(SIZE(CRECFM2T,1)))
372     YRECT(1:LEN(YRECT))(:)=' '
373     INB=0
374     DO JI=1,NNB
375     IF(NNUMT(JI,J) /= 0)THEN
376       INB=INB+1
377       YRECT(INB)=CRECFM2T(JI,J)
378       YRECT(INB)=ADJUSTL(YRECT(INB))
379 !     print *,' INB, YRECT ',INB,YRECT(INB)
380     ENDIF    
381     ENDDO
382
383     ALLOCATE(YRECID(NNB+100),YKEEP(NNB+100))
384     YRECID(:)(1:LEN(YRECID))=' '
385     YKEEP(:)(1:LEN(YRECID))=' '
386
387     IID=0
388     DO JI = 1,INB-1
389       YREF(1:LEN(YREF))=' '
390       IL=LEN_TRIM(YRECT(JI))-1
391       IF (IL > 15)THEN
392         print *,' Len GROUPE -1 > 15 ',IL,YRECT(JI)
393       ENDIF
394       YREF(1:IL)=YRECT(JI)(1:IL)
395 !     YREF=ADJUSTL(YREF)
396       IF(YREF(1:IL) == 'PABS' .OR. YREF(1:IL) == 'POVO' .OR. &
397          YREF(1:IL) == 'TH')THEN
398       IF(YRECT(JI)(IL+1:IL+1) == 'M')THEN
399       DO JIP1=JI+1,INB
400 !     DO JIP1=2,INB
401         IL=LEN_TRIM(YRECT(JIP1))-1
402         IF(YRECT(JIP1)(1:IL) == YREF .AND. YRECT(JIP1)(IL+1:IL+1) == 'T')THEN
403           IID=IID+1
404           YRECID(IID)=' '
405           YRECID(IID)=YREF
406           YRECID(IID)=ADJUSTL(YRECID(IID))
407           EXIT
408         ENDIF
409       ENDDO
410       ENDIF
411       ENDIF
412     ENDDO
413     print *,' DELETION OF PARAMETERS AT TIME t-dt ? (enter 1) '
414     print *,' DELETION OF PARAMETERS AT TIME t    ? (enter 2) '
415     print *,' NO DELETION                         ? (enter 0) '
416     print *,' (Question to select automatically parameters for vertical interpolations)'
417     READ(5,*)ICODEL
418     YCAR80(1:LEN(YCAR80))=' '
419     WRITE(YCAR80,*)ICODEL
420     YCAR80=ADJUSTL(YCAR80)
421     WRITE(80,'(A80)')YCAR80
422     IF(ICODEL == 0)THEN
423     ELSE IF(ICODEL == 1)THEN
424       DO JI=1,IID
425       YRECID(JI)=ADJUSTL(ADJUSTR(YRECID(JI))//'M')
426 !     YRECID(1:IID)=ADJUSTL(ADJUSTR(YRECID(1:IID))//'M')
427       ENDDO
428     ELSE IF(ICODEL == 2)THEN
429       DO JI=1,IID
430       YRECID(JI)=ADJUSTL(ADJUSTR(YRECID(JI))//'T')
431 !     YRECID(1:IID)=ADJUSTL(ADJUSTR(YRECID(1:IID))//'T')
432       ENDDO
433     ENDIF
434     
435 !   print *,' ICODEL,IID,YRECID ',ICODEL,IID,YRECID(1:IID)
436
437     I4=0
438     YPRI=' '
439 !   IF(ICODEL /= 0)THEN
440
441     print *,' PARAMETRES RESTANTS'
442     DO JI = 1,NNB
443       DO JIP1 = 1,IID
444         IF(CRECFM2T(JI,J) == YRECID(JIP1))THEN
445         NNUMT(JI,J)=0
446         EXIT
447         ENDIF
448       ENDDO
449       IF(NNUMT(JI,J) /= 0)THEN
450         I4=I4+1
451         YPRI(I4)=CRECFM2T(JI,J)
452         IF(I4 == 4 .OR. JI == NNB)THEN
453           print 10,YPRI
454           I4=0
455           YPRI=' '
456         ENDIF
457       ENDIF     
458     ENDDO
459 ! Donc ICI ds YRECID(1:IID), il y avait les parametres a supprimer et
460 ! qui viennent de l'etre en mettant le NNUMT(,) correspondant a zero.
461 ! Dec 2000
462     IKEEP=0
463     IKEEP=IKEEP+1
464     YKEEP(IKEEP)='ZS'
465     YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
466     DO JI = 1,NNB
467       IF(NNUMT(JI,J) /= 0)THEN
468         IF(CRECFM2T(JI,J) == 'PABSM')THEN
469           IKEEP=IKEEP+1
470           YKEEP(IKEEP)='PABSM'
471           YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
472         ELSEIF(CRECFM2T(JI,J) == 'PABST')THEN
473           IKEEP=IKEEP+1
474           YKEEP(IKEEP)='PABST'
475           YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
476         ELSEIF(CRECFM2T(JI,J) == 'THM')THEN
477           IKEEP=IKEEP+1
478           YKEEP(IKEEP)='THM'
479           YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
480         ELSEIF(CRECFM2T(JI,J) == 'THT')THEN
481           IKEEP=IKEEP+1
482           YKEEP(IKEEP)='THT'
483           YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
484         ELSEIF(CRECFM2T(JI,J) == 'POVOM')THEN
485           IKEEP=IKEEP+1
486           YKEEP(IKEEP)='POVOM'
487           YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
488         ELSEIF(CRECFM2T(JI,J) == 'POVOT')THEN
489           IKEEP=IKEEP+1
490           YKEEP(IKEEP)='POVOT'
491           YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
492         ENDIF
493       ENDIF
494     ENDDO
495 !   ENDIF     
496
497     print *,' '
498     print *,' Some parameters(if exist) are automatically recorded (for vert. interpolations):'
499     print *,' --> ',(YKEEP(JI)(1:LEN_TRIM(YKEEP(JI))+1),JI=1,IKEEP)
500     print *,' '
501 ! Dec 2000
502
503     YREPON(1:LEN(YREPON))=' '
504     print *,' Do you want to KEEP others parameters ? (y/n) '
505     READ(5,*)YREPON
506     YCAR80(1:LEN(YCAR80))=' '
507     YCAR80=YREPON
508     YCAR80=ADJUSTL(YCAR80)
509     WRITE(80,'(A80)')YCAR80
510     IF(YREPON == 'y' .OR. YREPON == 'yes' .OR. YREPON == 'o' .OR. &
511     YREPON == 'oui' .OR. YREPON == 'Y' .OR. YREPON == 'YES' .OR. YREPON == &
512      'O' .OR. YREPON == 'OUI')THEN
513       print *,' '
514       print *,' Enter their names in UPPERCASE  (1/1 line) '
515       print *,' End by END '
516       print *,' '
517       print *,' NOTA: if you want to plot RS ,don''t forget : RVM,UM,VM or RVT,UT,VT'
518       print *,' '
519       DO JI=1,10000
520 !       IID=IID+1
521         IKEEP=IKEEP+1
522 !       YRECID(IID)=' '
523         YKEEP(IKEEP)=' '
524         READ(5,*)YKEEP(IKEEP)
525 !       READ(5,*)YRECID(IID)
526 !       YRECID(IID)=ADJUSTL(YRECID(IID))
527         YKEEP(IID)=ADJUSTL(YKEEP(IID))
528         YCAR80(1:LEN(YCAR80))=' '
529 !       YCAR80=YRECID(IID)  
530         YCAR80=YKEEP(IKEEP)  
531         YCAR80=ADJUSTL(YCAR80)
532         WRITE(80,'(A80)')YCAR80
533 !       IF(YRECID(IID) == 'END')THEN
534         IF(YKEEP(IKEEP) == 'END')THEN
535           CLOSE(80)
536           EXIT
537         ENDIF
538       ENDDO
539     ENDIF
540 !   Donc ICI ds YKEEP(1:IKEEP), on a les variables =/= intouchables a garder
541 !   print *,' YRECID'
542 !   print 10,YRECID(1:IID)
543 !   print *,' CRECFM2T'
544 !   print 10,CRECFM2T(1:NNB,J)
545 !   print *,' PARAMETRES RESTANTS'
546     10 FORMAT(1X,4A19)
547     I4=0
548 !   YPRI(:)=' '
549 !   IF(ICODEL /= 0)THEN
550     DO JI = 1,NNB
551 ! Dec 2000
552       IF(NNUMT(JI,J) /= 0)THEN
553         IOK=0
554 !       DO JIP1 = 1,IID
555         DO JIP1 = 1,IKEEP
556           IF(CRECFM2T(JI,J) == YKEEP(JIP1))THEN
557           IOK=1
558           EXIT
559           ENDIF
560         ENDDO
561         IF(IOK == 0)THEN
562           NNUMT(JI,J)=0
563         ENDIF
564       ENDIF
565 ! Dec 2000
566       IF(NNUMT(JI,J) /= 0)THEN
567         IF(I4 == 4)THEN
568         print 10,YPRI(1:I4)
569         I4=0
570         YPRI(1:4)=' '
571         ENDIF
572         I4=I4+1
573         YPRI(I4)=CRECFM2T(JI,J)
574       ENDIF     
575       IF(JI == NNB)THEN
576         print 10,YPRI(1:I4)
577       ENDIF
578     ENDDO
579
580 !   ENDIF     
581
582
583   ENDIF
584 !              
585   IF(J == 1)THEN
586     DO JI=1,NNB
587 !      5.43      Elimination des dates
588 !
589       IDA=INDEX(CRECFM2T(JI,J),'%TDA')
590       IF(IDA /= 0)THEN
591         NNUMT(JI,J)=0
592       ENDIF
593       IDA=INDEX(CRECFM2T(JI,J),'%TIM')
594       IF(IDA /= 0)THEN
595         NNUMT(JI,J)=0
596       ENDIF
597 !        5.44  Elimination des champs dont le nom depasse 13 caracteres
598 !        (13 = 16 (=max.LEN(RECFM)=JPNCPN) -3 (=LEN('.TYpe','.DIm','.TItre',
599 !                              '.UNite','.COmment','.PRoc1','.TRajt','.DAtim'))
600       IF (LEN_TRIM(CRECFM2T(JI,J))>13 .AND. NNUMT(JI,J)/=0) THEN
601         NNUMT(JI,J)=0
602         print*,'Variable ',CRECFM2T(JI,J), ' not written (name too long)'
603         WRITE(NLUOUTD,*)'Variable ',CRECFM2T(JI,J), ' not written (name too long)'
604       END IF
605
606   ENDDO
607 ENDIF
608 !
609 !*       5.5   Lecture et ecriture des autres champs
610 !
611   CALL WRITE_OTHERSFIELDS(J,CFILEDIA,CLUOUTDIA)
612 !
613 !*       5.6   Fermeture du Fichier d'entree traite et liberation de l'unite
614 !              logique correspondante
615 !
616   CALL FMCLOS(CNAMFILED(J),'KEEP',CLUOUTD,NRESP)
617
618 ENDDO
619 !
620 !*       6.    Terminaison du fichier diachronique et impression du nom des
621 !              groupes enregistres
622 !              -------------------------------------------------------------
623 !
624 CALL MENU_DIACHRO(CFILEDIA,CLUOUTDIA,'END')
625 CALL MENU_DIACHRO(CFILEDIA,CLUOUTDIA,'READ')
626
627 CLOSE(NLUOUTD)
628 CALL FMFREE(CLUOUTD,CLUOUTD,NRESP)
629 !
630 !*       7.    Fermeture du fichier diachronique 
631 !              ---------------------------------
632 !
633 CALL FMCLOS(CFILEDIA,'KEEP',CLUOUTDIA,NRESP)
634 !------------------------------------------------------------------------------
635 !
636 !*      4.    EPILOGUE
637 !             --------
638
639 STOP
640
641 END PROGRAM FM2DIACHRO