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

Last change on this file since 55 was 16, checked in by bellier, 18 years ago

JB: add Id (ommited !)

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