source: IOIPSL/trunk/tools/ncunderflow.f90 @ 434

Last change on this file since 434 was 386, checked in by bellier, 16 years ago

Added CeCILL License information

  • Property svn:keywords set to Id
File size: 13.6 KB
Line 
1MODULE declare
2! -*- Mode: f90 -*-
3!$Id$
4!-
5! This software is governed by the CeCILL license
6! See IOIPSL/IOIPSL_License_CeCILL.txt
7!-
8! f90 -L/usr/local/lib -lnetcdf -align dcommons -g
9!     -ladebug -check format -check bounds
10!     -check output_conversion -fpe1
11!     -I/usr/local/include -free -arch host -tune host
12!     -warn declarations -warn argument_checking
13!     ncunderflow.f  -o ncunderflow
14!
15! ifc -FR -cl,ncunderflow.pcl -o ncunderflow ncunderflow.f
16!     -L/usr/local/install/netcdf/lib/libnetcdf.a -lPEPCF90
17!
18  IMPLICIT NONE
19  INTEGER, PARAMETER :: r4 = 4, r8 = 8, i4 = 4, i8 = 8
20  INTEGER, PARAMETER :: il = KIND(1)
21  LOGICAL :: ldebug = .FALSE.
22  INTEGER (kind = il) :: nout = 0, nerr = 0         ! Standard output, standard error
23  CHARACTER (LEN=4), PARAMETER :: cerror = 'VOID'
24END MODULE declare
25!!
26MODULE mod_nfdiag
27CONTAINS
28  SUBROUTINE nfdiag ( kios, clmess, lcd)
29    !!
30    !! Imprime un message d'erreur NetCDF
31    !!
32    USE declare
33    IMPLICIT NONE
34    INCLUDE 'netcdf.inc'
35    !!
36    INTEGER (kind=i4), INTENT (in) :: kios
37    CHARACTER (len = *), INTENT (in) :: clmess
38    LOGICAL, INTENT (in), OPTIONAL :: lcd 
39    CHARACTER (len = 80) :: clt
40    LOGICAL :: ld
41    !!
42    IF ( PRESENT ( lcd)) THEN
43        ld = lcd
44    ELSE
45        ld = ldebug
46    ENDIF
47    !!
48    clt = TRIM ( NF_STRERROR ( kios) )
49    !!
50    IF ( ld ) THEN
51        IF ( kios == NF_NOERR ) THEN
52            WRITE ( unit = nout, fmt = * ) "OK : ", TRIM (clmess)
53        ELSE
54            WRITE ( unit = nout, fmt = * ) "ERROR : ", TRIM (clmess), " : ", TRIM ( clt), " : ", kios
55            IF ( .NOT. ld ) STOP
56        END IF
57    ELSE
58        IF ( kios /= NF_NOERR ) THEN
59            WRITE ( unit = nout, fmt = * ) "ERROR : ", TRIM (clmess), " : ", TRIM ( clt), " : ", kios
60            STOP
61        END IF
62    ENDIF
63    !!
64    RETURN
65    !!
66  END SUBROUTINE nfdiag
67  !!
68END MODULE mod_nfdiag
69
70MODULE mod_lec
71CONTAINS
72  !!
73  SUBROUTINE lec (chaine, cval, c_c)
74    !!
75    USE declare
76    IMPLICIT NONE
77    !!
78    CHARACTER (len = *), INTENT ( inout) :: chaine
79    CHARACTER (len = *), INTENT ( inout) :: cval
80    CHARACTER (len=*), OPTIONAL :: c_c
81    INTEGER (kind = il) :: ji, ji1, ji2, ji3, jl, jb
82    INTEGER (kind = i4) :: index
83    !!
84    !! Read character string up to ':' or ',', or in c_c if present
85    !! Returns the real before the character (xerror if not available)
86    !! Reduce the string
87    !!
88    jl = LEN (chaine) ; jb = LEN_TRIM (chaine)
89    IF ( ldebug) WRITE ( nout, *) 'Lec : jl, jb ', jl, jb
90    IF ( jb == 0 ) THEN
91        cval = cerror
92    ELSE
93        ji1 = INDEX (chaine, ':') ; ji2 = INDEX (chaine, ',')
94        IF ( PRESENT (c_c)) THEN
95            ji3 = INDEX (chaine, c_c) ; ji = MAX (ji1, ji2, ji3)
96        ELSE
97            ji = MAX (ji1, ji2)
98        ENDIF
99        IF ( ji == 0 ) THEN
100            READ ( chaine (1:jb) , fmt = * ) cval
101            chaine (1:jl-jb) = chaine (jb+1:jl)
102        ELSE IF ( ji == 1 ) THEN
103            cval = cerror
104            chaine (1:jl-1) = chaine (2:jl)
105        ELSE
106            cval = chaine (1:ji-1)
107            chaine (1:jl-ji) = chaine (ji+1:jl )
108        END IF
109    END IF
110    !!
111  END SUBROUTINE lec
112END MODULE mod_lec
113
114PROGRAM ncunderflow
115
116  ! Ce programme ouvre un fichier de donnees au format netcdf
117  ! et met a zero toutes les valeurs trop petites pour etre
118  ! representees par un reel sur 4 octets au format IEEE
119  !
120  ! Revision 2.0  2004/04/05 14:47:50  adm
121  ! JB+MAF+AC: switch to IOIPSL 2.0 (1)
122  !
123  ! Revision 1.1  2003/04/09 15:21:56  adm
124  ! add ncunderflow in IOIPSL
125  ! and modify AA_make to take it into account
126  ! SD + MAF
127  !
128  ! Revision 1.1  2001/02/07  14:36:07  jypeter
129  ! J-Y Peterschmitt / LMCE / 07/02/2001
130  ! Initial revision
131  !
132  USE declare
133  USE mod_nfdiag
134  USE mod_lec
135  IMPLICIT NONE
136
137  INCLUDE 'netcdf.inc'
138
139  INTEGER (kind=il), EXTERNAL :: iargc
140
141  ! Nombre maximal de dimensions : 6
142
143  INTEGER (kind=il), PARAMETER :: jpmaxdim = 6, jpmaxvar = 1024
144
145  CHARACTER (len = 128) :: clnomprog, clnomfic
146  CHARACTER (len = 1024) :: clistvar, clecline
147  CHARACTER (len = 128), DIMENSION(jpmaxdim) :: clnomdim
148  CHARACTER (len = 128), DIMENSION(jpmaxvar) :: clvarcmd, clvarfic, clvar ! Nom des variables dans le fichier est sur la ligne de commande.
149  LOGICAL :: lrever = .FALSE. ! Si .true., on traite toutes les variables sauf celle de la ligne de commande
150  LOGICAL :: lnocoord = .FALSE. ! Si .truee., on exclu les variables coordonnées
151  LOGICAL :: lverbose = .TRUE.
152 
153  INTEGER (kind=il) :: incid, ircode, ivarid, ivartype, inbdim, inbatt
154  INTEGER (kind=il) :: nvarcmd, nvarfic, nvar, nfile, jvarcmd, jvarfic, jvar, jfile, ierr
155  INTEGER (kind=il) :: ji, jdim3, jdim4, jdim5, jdim6, j1, j2, j3, jarg, ncumul
156  INTEGER (kind=il), DIMENSION(jpmaxdim) :: idimid, idimsize, istart, icount
157  REAL (kind=r4), DIMENSION(:,:), ALLOCATABLE :: zdatacorr
158  REAL (kind=r8), DIMENSION(:,:), ALLOCATABLE :: zdata
159  REAL (kind=r4) :: reps = TINY (1.0_r4) * 10.0_r4
160  LOGICAL :: lok
161
162  ! Verification du nombre de parametres
163  IF(iargc() .LT. 2) THEN
164      CALL usage
165      STOP
166  ENDIF
167
168  ! Aide
169  jarg = 1
170  Lab1: DO WHILE ( jarg <= 3 )
171    IF (ldebug) WRITE(nout,*) 'lecture ligne commande ', jarg
172    CALL getarg (jarg,clecline)
173    IF ( clecline(1:1) /= '-' ) EXIT Lab1
174    IF ( clecline(1:2) == '-h' .OR. clecline(1:2) == '-?'  ) THEN
175        CALL usage
176        STOP
177    ELSE IF ( clecline(1:2) == '-x' ) THEN
178        lrever = .TRUE. 
179    ELSE IF ( clecline(1:2) == '-d' ) THEN
180        ldebug = .TRUE. 
181    ELSE IF ( clecline(1:2) == '-V' ) THEN
182        lverbose = .FALSE. 
183    ELSE IF ( clecline(1:2) == '-v' ) THEN
184        jarg = jarg + 1
185        ! Recuperation des noms de variables
186        IF (ldebug) WRITE(nout,*) 'lecture liste vriables ', jarg
187        CALL getarg (jarg,clistvar)
188        clistvar = TRIM(ADJUSTL(clistvar))
189        jvarcmd = 0 ; nvarcmd = 0
190        SeekVar: DO WHILE ( .TRUE. )
191          CALL lec ( clistvar, clvarcmd(jvarcmd+1)(:) )
192          IF ( TRIM(clvarcmd(jvarcmd+1)(:)) == cerror ) EXIT SeekVar
193          jvarcmd = jvarcmd + 1
194          nvarcmd = jvarcmd
195          IF (ldebug) WRITE(nout,*) 'affecte variable ', jvarcmd, TRIM(clvarcmd(jvarcmd))
196        END DO SeekVar
197    ENDIF
198    jarg = jarg + 1
199  END DO Lab1
200
201  ! Boucle sur les fichiers
202  FileLoop: DO jfile = jarg, iargc()
203   
204    ! Recuperation du nom du fichier a traiter
205    CALL getarg ( jfile, clnomfic)
206   
207    ! Ouverture du fichier
208    CALL nfdiag ( NF_OPEN ( TRIM(clnomfic), NF_WRITE, incid ), "Opening " // TRIM(clnomfic) )
209    WRITE (nout,*) TRIM(clnomfic)
210
211    ! Recuparation de la liste des variables du fichier
212    nvarfic = 0
213    DO jvarfic = 1, jpmaxvar
214      j3 = NF_INQ_VAR ( incid, jvarfic, clvarfic(jvarfic)(:), ivartype, inbdim, idimid, inbatt)
215      IF ( j3 /= NF_NOERR ) EXIT
216      nvarfic = jvarfic
217    END DO
218
219    ! Liste des variables a traiter
220    IF ( lrever ) THEN
221        IF ( nvarcmd == 0) THEN
222            clvar = clvarfic
223            nvar  = nvarfic
224        ELSE
225            jvar = 0
226            DO jvarfic = 1, nvarfic
227              lok = .TRUE.
228              DO jvarcmd = 1, nvarcmd
229                IF ( TRIM(clvarfic(jvarfic)(:)) == TRIM(clvarcmd(jvarcmd)(:)) ) THEN
230                    lok = .FALSE.
231                END IF
232              END DO
233              IF ( lok) THEN
234                  jvar = jvar + 1
235                  clvar(jvar) = clvarfic(jvarfic)
236              END IF
237            END DO
238            nvar = jvar
239        END IF
240    ELSE
241        clvar = clvarcmd
242        nvar  = nvarcmd
243    END IF
244
245    ncumul = 0
246    VarLoop: DO jvar = 1, nvar 
247     
248      IF (lverbose) &
249         & WRITE(nout, FMT='("Correction de ", A, " dans ", A, " : ", $)') TRIM(clvar(jvar)(:)), TRIM(clnomfic)
250
251      ! Passage de netcdf en mode 'erreurs non fatales'
252      !  CALL ncpopt(NCVERBOS)
253      ! En fait, on reste dans le mode par defaut, dans lequel une erreur
254      ! netcdf cause un arret du programme. Du coup, il n'est pas
255      ! necessaire de tester la valeur de la variable ircode
256      ! ATTENTION! Si jamais on veut arreter le programme a cause d'une
257      ! erreur ne provenant pas de netcdf, il faut penser a fermer
258      ! manuellement le fichier avec un appel a ncclos
259     
260      ! Recuperation de l'identificateur de la variable
261      CALL nfdiag ( NF_INQ_VARID ( incid, TRIM(clvar(jvar)(:)), ivarid), "Get var id " // TRIM(clvar(jvar)(:)))
262
263      ivartype = 0 ; idimid = 0 ; inbdim = 0 ; inbatt = 0
264      ! Recuperation du nombre de dimensions de la variable
265      CALL nfdiag ( NF_INQ_VAR ( incid, ivarid, clvar(jvar)(:), ivartype, inbdim, idimid, inbatt),  &
266         & "Get var info " // TRIM(clvar(jvar)(:)))
267     
268      IF(inbdim .GT. jpmaxdim) THEN
269          WRITE(nout,*)
270          WRITE(nout, *) 'La variable ', TRIM(clvar(jvar)(:)), ' a trop de dimensions'
271          CALL nfdiag ( NF_CLOSE (incid), "Closing file")
272          STOP
273      ENDIF
274     
275      ! Recuperation des dimensions effectives
276      idimsize(3:jpmaxdim) = 1 ! Au cas ou la variable n'ait que
277      ! 2 ou 3 dims, on initialise ces valeurs
278      ! qui serviront dans le controle des boucles
279      ! et qui auraient une valeur indefinie sinon
280      DO ji = 1, inbdim
281        CALL nfdiag ( NF_INQ_DIM ( incid, idimid(ji), clnomdim(ji), idimsize(ji)), "NF_INQ_DIM")
282        IF (lverbose) WRITE(nout, '(A,A,A,I3,$)') '    ', TRIM(clnomdim(ji)), ' = ', idimsize(ji)
283        IF ( idimsize(ji) == 0 ) THEN
284            WRITE(nout, '(A,A,A,A,I3)') TRIM(clvar(jvar)(:)), ', ', TRIM(clnomdim(ji)), ' = ', idimsize(ji)
285            CYCLE VarLoop
286        END IF
287      ENDDO
288      IF (lverbose) WRITE(nout,*)
289      idimsize = MAX ( idimsize, 1)
290      ncumul = ncumul + 1
291     
292      ! Determination du type de la variable, en fonction du nom de
293      ! la premiere dimension
294!$$$  IF(INDEX(TRIM(clnomdim(1)),'ongitude') .NE. 0) THEN
295!$$$      ! var de type map ou 3d
296!$$$      write(nout, *) '  --> MAP/3D'
297!$$$  ELSE IF(INDEX(TRIM(clnomdim(1)),'atitude') .NE. 0) THEN
298!$$$      ! var de type xsec
299!$$$      write(nout, *) '  --> XSEC'
300!$$$  ELSE
301!$$$      WRITE(nout, *)
302!$$$      WRITE(nout, *) 'Bizarre, la premiere dimension n''est ni "longitude" ni "latitude"'
303!$$$      CALL ncclos(incid, ircode)
304!$$$      STOP
305!$$$  ENDIF
306
307      ! Reservation de memoire pour charger et traiter
308      ! une grille idimsize(1)*idimsize(2) de la variable
309      ALLOCATE(zdata(idimsize(1), idimsize(2)), stat=ierr)
310      IF(ierr .NE. 0) THEN
311          WRITE(nout, *) 'Erreur d''allocation memoire pour zdata'
312          CALL nfdiag ( NF_CLOSE (incid), "NF_CLOSE")
313          STOP
314      ENDIF
315      ALLOCATE(zdatacorr(idimsize(1), idimsize(2)), stat=ierr)
316      IF(ierr .NE. 0) THEN
317          WRITE(nout, *) 'Erreur d''allocation memoire pour zdatacorr'
318          CALL nfdiag ( NF_CLOSE (incid), "NF_CLOSE")
319          STOP
320      ENDIF
321
322      ! Parametrisation de la partie de la variable a charger en memoire
323      ! (une 'grille' que l'on lira autant de fois qu'il y a de niveaux et
324      !  de pas de temps)
325      ! Rappel : seuls les elements 1..inbdim des tableaux sont
326      ! significatifs et utiles
327
328      icount = 0
329     
330      DO jdim6 = 1, idimsize(6)
331        DO jdim5 = 1, idimsize(5)
332          DO jdim4 = 1, idimsize(4)
333            DO jdim3 = 1, idimsize(3)
334              istart = (/   1        ,      1      , jdim3, jdim4, jdim5, jdim6 /)
335              icount = (/ idimsize(1),  idimsize(2),   1  ,  1   ,  1   ,  1    /)
336
337              ! Chargement d'une 'grille' de donnees, en real*8
338              CALL nfdiag ( NF_GET_VARA_DOUBLE(incid, ivarid, istart(1:inbdim), icount(1:inbdim), zdata), &
339                 & "NF_GET_VARA_DOUBLE")
340              ! Mise a zero de toutes les valeurs trop petites pour etre
341              ! representees par un reel sur 4 octets au format IEEE.
342              ! Le truc est de faire une operation nulle (addition de 0)
343              ! sur des donnees qui posent problemes, EN AYANT COMPILE LE PROG
344              ! AVEC l'OPTION "-fpe1". Dans ce cas, les valeurs trop petites
345              ! sont remplacees par zero (0.0) et le programme continue,
346              ! au lieu de planter.
347              ! Il est possible de faire afficher le nb de valeurs qui ont pose
348              ! un pb en utilisant en plus l'option "-check underflow"
349              zdata = zdata + 0.0_r8
350              zdatacorr = REAL(zdata, KIND=r4)
351              WHERE ( ABS (zdatacorr) < reps) zdatacorr = 0.0_r4
352             
353              ! Sauvegarde de la grille corrigee dans le fichier
354              ! (a la place de la grille initiale), en real*4
355              CALL nfdiag ( NF_PUT_VARA_REAL(incid, ivarid, istart, icount, zdatacorr), "NF_PUT_VARA_REAL" )
356             
357            END DO
358          END DO
359        END DO
360      END DO
361     
362      DEALLOCATE ( zdata)
363      DEALLOCATE ( zdatacorr)
364     
365    END DO VarLoop
366   
367    WRITE (nout,*) 'ncunderflow, nombre de variables corrigees : ', ncumul
368
369    ! Fermeture du fichier
370    CALL nfdiag ( NF_CLOSE (incid), "Closing" )
371   
372  END DO FileLoop
373
374CONTAINS
375  SUBROUTINE usage
376    IMPLICIT NONE
377    CALL getarg (0, clnomprog)
378
379    WRITE(nout, FMT='("Command : ", A)') TRIM(clnomprog)
380    WRITE(nout, FMT='("Removes underflows in NetCDF files") ')
381    WRITE(nout, FMT='("Usage : ", A, " [-x] [-V] [-d] -v nomvar[,nomvar] nomfic [nomfic]")' ) TRIM(clnomprog)
382    WRITE(nout, FMT='("Options : ")' )
383    WRITE(nout, FMT='("  -V : mode verbose off. Default is verbose on.")' )
384    WRITE(nout, FMT='("  -d : debug mode on. Default is debug off.")' )
385    WRITE(nout, FMT='("  -v : gives list of variables to be corrected, separated by a coma.")' )
386    WRITE(nout, FMT='("  -x : reverses meaning of -v : given variable are not corrected")' )
387    WRITE(nout, FMT='("       if -x is given, and not -v, all variables are corrected.")' )
388   
389   
390    STOP
391  END SUBROUTINE usage
392 
393END PROGRAM ncunderflow
Note: See TracBrowser for help on using the repository browser.