405 lines
14 KiB
Fortran
405 lines
14 KiB
Fortran
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
|
||
MODULE declare
|
||
! -*- Mode: f90 -*-
|
||
!$Id: ncunderflow.f90 2281 2010-10-15 14:21:13Z smasson $
|
||
!-
|
||
! This software is governed by the CeCILL license
|
||
! See IOIPSL/IOIPSL_License_CeCILL.txt
|
||
!-
|
||
! f90 -L/usr/local/lib -lnetcdf -align dcommons -g
|
||
! -ladebug -check format -check bounds
|
||
! -check output_conversion -fpe1
|
||
! -I/usr/local/include -free -arch host -tune host
|
||
! -warn declarations -warn argument_checking
|
||
! ncunderflow.f -o ncunderflow
|
||
!
|
||
! ifc -FR -cl,ncunderflow.pcl -o ncunderflow ncunderflow.f
|
||
! -L/usr/local/install/netcdf/lib/libnetcdf.a -lPEPCF90
|
||
!
|
||
IMPLICIT NONE
|
||
INTEGER, PARAMETER :: r4 = 4, r8 = 8, i4 = 4, i8 = 8
|
||
INTEGER, PARAMETER :: il = KIND(1)
|
||
LOGICAL :: ldebug = .FALSE.
|
||
INTEGER (kind = il) :: nout = 0, nerr = 0 ! Standard output, standard error
|
||
CHARACTER (LEN=4), PARAMETER :: cerror = 'VOID'
|
||
END MODULE declare
|
||
!!
|
||
MODULE mod_nfdiag
|
||
CONTAINS
|
||
SUBROUTINE nfdiag ( kios, clmess, lcd)
|
||
!!
|
||
!! Imprime un message d'erreur NetCDF
|
||
!!
|
||
USE declare
|
||
IMPLICIT NONE
|
||
INCLUDE 'netcdf.inc'
|
||
!!
|
||
INTEGER (kind=i4), INTENT (in) :: kios
|
||
CHARACTER (len = *), INTENT (in) :: clmess
|
||
LOGICAL, INTENT (in), OPTIONAL :: lcd
|
||
CHARACTER (len = 80) :: clt
|
||
LOGICAL :: ld
|
||
!!
|
||
IF ( PRESENT ( lcd)) THEN
|
||
ld = lcd
|
||
ELSE
|
||
ld = ldebug
|
||
ENDIF
|
||
!!
|
||
clt = TRIM ( NF_STRERROR ( kios) )
|
||
!!
|
||
IF ( ld ) THEN
|
||
IF ( kios == NF_NOERR ) THEN
|
||
WRITE ( unit = nout, fmt = * ) "OK : ", TRIM (clmess)
|
||
ELSE
|
||
WRITE ( unit = nout, fmt = * ) "ERROR : ", TRIM (clmess), " : ", TRIM ( clt), " : ", kios
|
||
IF ( .NOT. ld ) STOP
|
||
END IF
|
||
ELSE
|
||
IF ( kios /= NF_NOERR ) THEN
|
||
WRITE ( unit = nout, fmt = * ) "ERROR : ", TRIM (clmess), " : ", TRIM ( clt), " : ", kios
|
||
STOP
|
||
END IF
|
||
ENDIF
|
||
!!
|
||
RETURN
|
||
!!
|
||
END SUBROUTINE nfdiag
|
||
!!
|
||
END MODULE mod_nfdiag
|
||
|
||
MODULE mod_lec
|
||
CONTAINS
|
||
!!
|
||
SUBROUTINE lec (chaine, cval, c_c)
|
||
!!
|
||
USE declare
|
||
IMPLICIT NONE
|
||
!!
|
||
CHARACTER (len = *), INTENT ( inout) :: chaine
|
||
CHARACTER (len = *), INTENT ( inout) :: cval
|
||
CHARACTER (len=*), OPTIONAL :: c_c
|
||
INTEGER (kind = il) :: ji, ji1, ji2, ji3, jl, jb
|
||
INTEGER (kind = i4) :: index
|
||
!!
|
||
!! Read character string up to ':' or ',', or in c_c if present
|
||
!! Returns the real before the character (xerror if not available)
|
||
!! Reduce the string
|
||
!!
|
||
jl = LEN (chaine) ; jb = LEN_TRIM (chaine)
|
||
IF ( ldebug) WRITE ( nout, *) 'Lec : jl, jb ', jl, jb
|
||
IF ( jb == 0 ) THEN
|
||
cval = cerror
|
||
ELSE
|
||
ji1 = INDEX (chaine, ':') ; ji2 = INDEX (chaine, ',')
|
||
IF ( PRESENT (c_c)) THEN
|
||
ji3 = INDEX (chaine, c_c) ; ji = MAX (ji1, ji2, ji3)
|
||
ELSE
|
||
ji = MAX (ji1, ji2)
|
||
ENDIF
|
||
IF ( ji == 0 ) THEN
|
||
READ ( chaine (1:jb) , fmt = * ) cval
|
||
chaine (1:jl-jb) = chaine (jb+1:jl)
|
||
ELSE IF ( ji == 1 ) THEN
|
||
cval = cerror
|
||
chaine (1:jl-1) = chaine (2:jl)
|
||
ELSE
|
||
cval = chaine (1:ji-1)
|
||
chaine (1:jl-ji) = chaine (ji+1:jl )
|
||
END IF
|
||
END IF
|
||
!!
|
||
END SUBROUTINE lec
|
||
END MODULE mod_lec
|
||
|
||
PROGRAM ncunderflow
|
||
|
||
! Ce programme ouvre un fichier de donnees au format netcdf
|
||
! et met a zero toutes les valeurs trop petites pour etre
|
||
! representees par un reel sur 4 octets au format IEEE
|
||
!
|
||
! Revision 2.0 2004/04/05 14:47:50 adm
|
||
! JB+MAF+AC: switch to IOIPSL 2.0 (1)
|
||
!
|
||
! Revision 1.1 2003/04/09 15:21:56 adm
|
||
! add ncunderflow in IOIPSL
|
||
! and modify AA_make to take it into account
|
||
! SD + MAF
|
||
!
|
||
! Revision 1.1 2001/02/07 14:36:07 jypeter
|
||
! J-Y Peterschmitt / LMCE / 07/02/2001
|
||
! Initial revision
|
||
!
|
||
USE declare
|
||
USE mod_nfdiag
|
||
USE mod_lec
|
||
IMPLICIT NONE
|
||
|
||
INCLUDE 'netcdf.inc'
|
||
|
||
INTEGER (kind=il), EXTERNAL :: iargc
|
||
|
||
! Nombre maximal de dimensions : 6
|
||
|
||
INTEGER (kind=il), PARAMETER :: jpmaxdim = 6, jpmaxvar = 1024
|
||
|
||
CHARACTER (len = 128) :: clnomprog, clnomfic
|
||
CHARACTER (len = 1024) :: clistvar, clecline
|
||
CHARACTER (len = 128), DIMENSION(jpmaxdim) :: clnomdim
|
||
CHARACTER (len = 128), DIMENSION(jpmaxvar) :: clvarcmd, clvarfic, clvar ! Nom des variables dans le fichier est sur la ligne de commande.
|
||
LOGICAL :: lrever = .FALSE. ! Si .true., on traite toutes les variables sauf celle de la ligne de commande
|
||
LOGICAL :: lnocoord = .FALSE. ! Si .truee., on exclu les variables coordonn<6E>es
|
||
LOGICAL :: lverbose = .TRUE.
|
||
|
||
INTEGER (kind=il) :: incid, ircode, ivarid, ivartype, inbdim, inbatt
|
||
INTEGER (kind=il) :: nvarcmd, nvarfic, nvar, nfile, jvarcmd, jvarfic, jvar, jfile, ierr
|
||
INTEGER (kind=il) :: ji, jdim3, jdim4, jdim5, jdim6, j1, j2, j3, jarg, ncumul
|
||
INTEGER (kind=il), DIMENSION(jpmaxdim) :: idimid, idimsize, istart, icount
|
||
REAL (kind=r4), DIMENSION(:,:), ALLOCATABLE :: zdatacorr
|
||
REAL (kind=r8), DIMENSION(:,:), ALLOCATABLE :: zdata
|
||
REAL (kind=r4) :: reps = TINY (1.0_r4) * 10.0_r4
|
||
LOGICAL :: lok
|
||
|
||
! Verification du nombre de parametres
|
||
IF(iargc() .LT. 2) THEN
|
||
CALL usage
|
||
STOP
|
||
ENDIF
|
||
|
||
! Aide
|
||
jarg = 1
|
||
Lab1: DO WHILE ( jarg <= 3 )
|
||
IF (ldebug) WRITE(nout,*) 'lecture ligne commande ', jarg
|
||
CALL getarg (jarg,clecline)
|
||
IF ( clecline(1:1) /= '-' ) EXIT Lab1
|
||
IF ( clecline(1:2) == '-h' .OR. clecline(1:2) == '-?' ) THEN
|
||
CALL usage
|
||
STOP
|
||
ELSE IF ( clecline(1:2) == '-x' ) THEN
|
||
lrever = .TRUE.
|
||
ELSE IF ( clecline(1:2) == '-d' ) THEN
|
||
ldebug = .TRUE.
|
||
ELSE IF ( clecline(1:2) == '-V' ) THEN
|
||
lverbose = .FALSE.
|
||
ELSE IF ( clecline(1:2) == '-v' ) THEN
|
||
jarg = jarg + 1
|
||
! Recuperation des noms de variables
|
||
IF (ldebug) WRITE(nout,*) 'lecture liste vriables ', jarg
|
||
CALL getarg (jarg,clistvar)
|
||
clistvar = TRIM(ADJUSTL(clistvar))
|
||
jvarcmd = 0 ; nvarcmd = 0
|
||
SeekVar: DO WHILE ( .TRUE. )
|
||
CALL lec ( clistvar, clvarcmd(jvarcmd+1)(:) )
|
||
IF ( TRIM(clvarcmd(jvarcmd+1)(:)) == cerror ) EXIT SeekVar
|
||
jvarcmd = jvarcmd + 1
|
||
nvarcmd = jvarcmd
|
||
IF (ldebug) WRITE(nout,*) 'affecte variable ', jvarcmd, TRIM(clvarcmd(jvarcmd))
|
||
END DO SeekVar
|
||
ENDIF
|
||
jarg = jarg + 1
|
||
END DO Lab1
|
||
|
||
! Boucle sur les fichiers
|
||
FileLoop: DO jfile = jarg, iargc()
|
||
|
||
! Recuperation du nom du fichier a traiter
|
||
CALL getarg ( jfile, clnomfic)
|
||
|
||
! Ouverture du fichier
|
||
CALL nfdiag ( NF_OPEN ( TRIM(clnomfic), NF_WRITE, incid ), "Opening " // TRIM(clnomfic) )
|
||
WRITE (nout,*) TRIM(clnomfic)
|
||
|
||
! Recuparation de la liste des variables du fichier
|
||
nvarfic = 0
|
||
DO jvarfic = 1, jpmaxvar
|
||
j3 = NF_INQ_VAR ( incid, jvarfic, clvarfic(jvarfic)(:), ivartype, inbdim, idimid, inbatt)
|
||
IF ( j3 /= NF_NOERR ) EXIT
|
||
nvarfic = jvarfic
|
||
END DO
|
||
|
||
! Liste des variables a traiter
|
||
IF ( lrever ) THEN
|
||
IF ( nvarcmd == 0) THEN
|
||
clvar = clvarfic
|
||
nvar = nvarfic
|
||
ELSE
|
||
jvar = 0
|
||
DO jvarfic = 1, nvarfic
|
||
lok = .TRUE.
|
||
DO jvarcmd = 1, nvarcmd
|
||
IF ( TRIM(clvarfic(jvarfic)(:)) == TRIM(clvarcmd(jvarcmd)(:)) ) THEN
|
||
lok = .FALSE.
|
||
END IF
|
||
END DO
|
||
IF ( lok) THEN
|
||
jvar = jvar + 1
|
||
clvar(jvar) = clvarfic(jvarfic)
|
||
END IF
|
||
END DO
|
||
nvar = jvar
|
||
END IF
|
||
ELSE
|
||
clvar = clvarcmd
|
||
nvar = nvarcmd
|
||
END IF
|
||
|
||
ncumul = 0
|
||
VarLoop: DO jvar = 1, nvar
|
||
|
||
IF (lverbose) &
|
||
& WRITE(nout, FMT='("Correction de ", A, " dans ", A, " : ", $)') TRIM(clvar(jvar)(:)), TRIM(clnomfic)
|
||
|
||
! Passage de netcdf en mode 'erreurs non fatales'
|
||
! CALL ncpopt(NCVERBOS)
|
||
! En fait, on reste dans le mode par defaut, dans lequel une erreur
|
||
! netcdf cause un arret du programme. Du coup, il n'est pas
|
||
! necessaire de tester la valeur de la variable ircode
|
||
! ATTENTION! Si jamais on veut arreter le programme a cause d'une
|
||
! erreur ne provenant pas de netcdf, il faut penser a fermer
|
||
! manuellement le fichier avec un appel a ncclos
|
||
|
||
! Recuperation de l'identificateur de la variable
|
||
CALL nfdiag ( NF_INQ_VARID ( incid, TRIM(clvar(jvar)(:)), ivarid), "Get var id " // TRIM(clvar(jvar)(:)))
|
||
|
||
ivartype = 0 ; idimid = 0 ; inbdim = 0 ; inbatt = 0
|
||
! Recuperation du nombre de dimensions de la variable
|
||
CALL nfdiag ( NF_INQ_VAR ( incid, ivarid, clvar(jvar)(:), ivartype, inbdim, idimid, inbatt), &
|
||
& "Get var info " // TRIM(clvar(jvar)(:)))
|
||
|
||
IF(inbdim .GT. jpmaxdim) THEN
|
||
WRITE(nout,*)
|
||
WRITE(nout, *) 'La variable ', TRIM(clvar(jvar)(:)), ' a trop de dimensions'
|
||
CALL nfdiag ( NF_CLOSE (incid), "Closing file")
|
||
STOP
|
||
ENDIF
|
||
|
||
! Recuperation des dimensions effectives
|
||
idimsize(3:jpmaxdim) = 1 ! Au cas ou la variable n'ait que
|
||
! 2 ou 3 dims, on initialise ces valeurs
|
||
! qui serviront dans le controle des boucles
|
||
! et qui auraient une valeur indefinie sinon
|
||
DO ji = 1, inbdim
|
||
CALL nfdiag ( NF_INQ_DIM ( incid, idimid(ji), clnomdim(ji), idimsize(ji)), "NF_INQ_DIM")
|
||
IF (lverbose) WRITE(nout, '(A,A,A,I3,$)') ' ', TRIM(clnomdim(ji)), ' = ', idimsize(ji)
|
||
IF ( idimsize(ji) == 0 ) THEN
|
||
WRITE(nout, '(A,A,A,A,I3)') TRIM(clvar(jvar)(:)), ', ', TRIM(clnomdim(ji)), ' = ', idimsize(ji)
|
||
CYCLE VarLoop
|
||
END IF
|
||
ENDDO
|
||
IF (lverbose) WRITE(nout,*)
|
||
idimsize = MAX ( idimsize, 1)
|
||
ncumul = ncumul + 1
|
||
|
||
! Determination du type de la variable, en fonction du nom de
|
||
! la premiere dimension
|
||
!$$$ IF(INDEX(TRIM(clnomdim(1)),'ongitude') .NE. 0) THEN
|
||
!$$$ ! var de type map ou 3d
|
||
!$$$ write(nout, *) ' --> MAP/3D'
|
||
!$$$ ELSE IF(INDEX(TRIM(clnomdim(1)),'atitude') .NE. 0) THEN
|
||
!$$$ ! var de type xsec
|
||
!$$$ write(nout, *) ' --> XSEC'
|
||
!$$$ ELSE
|
||
!$$$ WRITE(nout, *)
|
||
!$$$ WRITE(nout, *) 'Bizarre, la premiere dimension n''est ni "longitude" ni "latitude"'
|
||
!$$$ CALL ncclos(incid, ircode)
|
||
!$$$ STOP
|
||
!$$$ ENDIF
|
||
|
||
! Reservation de memoire pour charger et traiter
|
||
! une grille idimsize(1)*idimsize(2) de la variable
|
||
ALLOCATE(zdata(idimsize(1), idimsize(2)), stat=ierr)
|
||
IF(ierr .NE. 0) THEN
|
||
WRITE(nout, *) 'Erreur d''allocation memoire pour zdata'
|
||
CALL nfdiag ( NF_CLOSE (incid), "NF_CLOSE")
|
||
STOP
|
||
ENDIF
|
||
ALLOCATE(zdatacorr(idimsize(1), idimsize(2)), stat=ierr)
|
||
IF(ierr .NE. 0) THEN
|
||
WRITE(nout, *) 'Erreur d''allocation memoire pour zdatacorr'
|
||
CALL nfdiag ( NF_CLOSE (incid), "NF_CLOSE")
|
||
STOP
|
||
ENDIF
|
||
|
||
! Parametrisation de la partie de la variable a charger en memoire
|
||
! (une 'grille' que l'on lira autant de fois qu'il y a de niveaux et
|
||
! de pas de temps)
|
||
! Rappel : seuls les elements 1..inbdim des tableaux sont
|
||
! significatifs et utiles
|
||
|
||
icount = 0
|
||
|
||
DO jdim6 = 1, idimsize(6)
|
||
DO jdim5 = 1, idimsize(5)
|
||
DO jdim4 = 1, idimsize(4)
|
||
DO jdim3 = 1, idimsize(3)
|
||
istart = (/ 1 , 1 , jdim3, jdim4, jdim5, jdim6 /)
|
||
icount = (/ idimsize(1), idimsize(2), 1 , 1 , 1 , 1 /)
|
||
|
||
! Chargement d'une 'grille' de donnees, en real*8
|
||
CALL nfdiag ( NF_GET_VARA_DOUBLE(incid, ivarid, istart(1:inbdim), icount(1:inbdim), zdata), &
|
||
& "NF_GET_VARA_DOUBLE")
|
||
! Mise a zero de toutes les valeurs trop petites pour etre
|
||
! representees par un reel sur 4 octets au format IEEE.
|
||
! Le truc est de faire une operation nulle (addition de 0)
|
||
! sur des donnees qui posent problemes, EN AYANT COMPILE LE PROG
|
||
! AVEC l'OPTION "-fpe1". Dans ce cas, les valeurs trop petites
|
||
! sont remplacees par zero (0.0) et le programme continue,
|
||
! au lieu de planter.
|
||
! Il est possible de faire afficher le nb de valeurs qui ont pose
|
||
! un pb en utilisant en plus l'option "-check underflow"
|
||
zdata = zdata + 0.0_r8
|
||
zdatacorr = REAL(zdata, KIND=r4)
|
||
WHERE ( ABS (zdatacorr) < reps) zdatacorr = 0.0_r4
|
||
|
||
! Sauvegarde de la grille corrigee dans le fichier
|
||
! (a la place de la grille initiale), en real*4
|
||
CALL nfdiag ( NF_PUT_VARA_REAL(incid, ivarid, istart, icount, zdatacorr), "NF_PUT_VARA_REAL" )
|
||
|
||
END DO
|
||
END DO
|
||
END DO
|
||
END DO
|
||
|
||
DEALLOCATE ( zdata)
|
||
DEALLOCATE ( zdatacorr)
|
||
|
||
END DO VarLoop
|
||
|
||
WRITE (nout,*) 'ncunderflow, nombre de variables corrigees : ', ncumul
|
||
|
||
! Fermeture du fichier
|
||
CALL nfdiag ( NF_CLOSE (incid), "Closing" )
|
||
|
||
END DO FileLoop
|
||
|
||
CONTAINS
|
||
SUBROUTINE usage
|
||
IMPLICIT NONE
|
||
CALL getarg (0, clnomprog)
|
||
|
||
WRITE(nout, FMT='("Command : ", A)') TRIM(clnomprog)
|
||
WRITE(nout, FMT='("Removes underflows in NetCDF files") ')
|
||
WRITE(nout, FMT='("Usage : ", A, " [-x] [-V] [-d] -v nomvar[,nomvar] nomfic [nomfic]")' ) TRIM(clnomprog)
|
||
WRITE(nout, FMT='("Options : ")' )
|
||
WRITE(nout, FMT='(" -V : mode verbose off. Default is verbose on.")' )
|
||
WRITE(nout, FMT='(" -d : debug mode on. Default is debug off.")' )
|
||
WRITE(nout, FMT='(" -v : gives list of variables to be corrected, separated by a coma.")' )
|
||
WRITE(nout, FMT='(" -x : reverses meaning of -v : given variable are not corrected")' )
|
||
WRITE(nout, FMT='(" if -x is given, and not -v, all variables are corrected.")' )
|
||
|
||
|
||
STOP
|
||
END SUBROUTINE usage
|
||
|
||
END PROGRAM ncunderflow
|