Version of MareNostrum4 just copied

EnKF-MPI-TOPAZ/CHANGELOG

@@ -0,0 +1,31 @@
+v. 2.10, PS 25/08/2010
+
+- Changed usage of EnKF. Now the parameters are communicated to the program via
+  a file with Fortran name list, passed as the first parameter.
+
+- Added a new module m_parameters.F90 to handle the above.
+
+- Pass the inflation magnitude as a parameter to update_fields(), rather than 
+  calc_X5(). This enables to vary inflation depending on the updated field, 
+  which is necessary for parameter estimation
+
+- Created a new modue m_uobs.F90 and moved there get_uobs(), now renamed as 
+  uobs_get().
+
+- Added pieces of code to handle estimation for SST and SSH biases. The 
+  corresponding 2D fields are supposed to be named as "sstb" and "msshb". The
+  estimates are subtracted from the ensemble fields of those in prep_4_EnKF().
+  Also, the estimate for SST  bias is subtracted from the in-situ T fields in
+  the ixed layer, smoothed by a factor exp(-(z /mld)**2).
+
+- Removed m_read_mean_ssh.F90. There is a duplication of this procedure placed
+  now in p_prep_4_EnKF.F90 in Prep/m_get_def_wet_point.F90, which is to removed
+  in future.
+
+- Made "obs" and "nobs" global throughout the code, residing in m_obs. 
+  Accordingly, the variable name for local observations in m_local_analysis.F90
+  became "lobs" and "nlobs". 
+
+- Made all observation tags in capital letters (backward compatible).
+
+- removed m_datatest.F90; moved testing the obs range to m_obs.F90.

EnKF-MPI-TOPAZ/Config/make.fimm

@@ -0,0 +1,70 @@
+# Knuts home directory (contains some libs/includes)
+KHOME = /home/fimm/nersc/knutali/
+
+#Compiler -- F90
+CF90 = /local/openmpi/bin/mpif90
+
+#Compiler -- F77
+CF77 = $(CF90)
+
+# Compiler -- C
+CC=/local/openmpi/bin/mpicc
+
+#Linker 
+LD =  $(CF90)
+
+
+#Paralellization opts
+#PARO = -openmp 
+PARO =
+
+#Size defaults - Change to real_size 64 for default double...
+SIZEO = -real_size 64 -double_size 64
+#SIZEO = 
+
+#Arch opts
+ARCHO= 
+
+#Optimalization opts
+OPTO= -O2
+
+#Inlining opts
+#INLO= -ip
+INLO=
+
+# Diverse options -swap endian IO -use medium memory model
+DIVO= -convert big_endian -mcmodel=medium
+
+# Flags for debugging. Empty optimization (OPTO above) to use debugging properly
+#
+#DEBUG_FLAGS = -g  -check bounds -fpstkchk -traceback -fpe0 
+DEBUG_FLAGS = -g  -check all -traceback -fpe0  -CA -CB -CS -CU -CV
+#DEBUG_FLAGS = 
+
+
+
+
+CFLAGS = -O
+F77FLG = -fixed
+F90FLG = -free
+
+# C preprocessor
+CPP = /usr/bin/cpp
+
+#CPP flags 
+CPPARCH = -traditional -DIA32 -DFFTW
+
+#This uses the OpenMPI implementation of mpi-2
+LIBS =  -L/local/netcdf/lib/ -lnetcdf  -L/local/openmpi/lib/ -lmpi \
+        -L/local/fftw/lib/ -lfftw3   \
+        -L/local/acml/ifort64/lib/ -lacml_mv -lacml -lg2c
+
+# Include dir for header and module files
+INCLUDEDIR= -I/local/netcdf/include -I/local/fftw/include \
+-I/local/openmpi/include
+
+
+# Put together flags
+FFLAGS    = $(SIZEO) $(OPTO) $(ARCHO) $(PARO)    $(INLO) $(DIVO) $(DEBUG_FLAGS) $(INCLUDEDIR)
+LINKFLAGS = $(SIZEO) $(OPTO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS)  
+

EnKF-MPI-TOPAZ/Config/make.hex.gnu

@@ -0,0 +1,40 @@
+INC_NETCDF = -I/home/nersc/pavelsa/local/include
+LIB_NETCDF = /home/nersc/pavelsa/local/lib/libnetcdf.a
+LIB_LAPACK = /home/nersc/pavelsa/local/lib/lapack.a /home/nersc/pavelsa/local/lib/tmglib.a /home/nersc/pavelsa/local/lib/blas.a 
+LIB_FFT = /opt/fftw/3.2.1/lib/libfftw3.a
+
+INCS = $(INC_NETCDF) -I/opt/fftw/3.2.2/include
+LIBS = $(LIB_LAPACK) $(LIB_NETCDF) $(LIB_FFT)
+
+ifeq ($(MPI),YES)
+	CF90 = /home/nersc/pavelsa/local/bin/mpif90
+	PARO =
+	CPPFLAGS = -DQMPI
+else
+	CF90 = /home/nersc/pavelsa/local/bin/g95
+	PAR0 =
+endif
+CF77 = $(CF90)
+LD = $(CF90)
+CPP = /usr/bin/cpp -traditional-cpp
+CC = gcc
+
+CPPARCH = -DIA32 -DFFTW -DNOMPIR8
+CPPFLAGS += -P $(CPPARCH) -DF90_NOFLUSH -D_G95_
+
+SIZEO = -r8
+#OPTO = -O2 -Wall
+OPTO = -Wall
+#ARCHO = -fno-second-underscore
+INLO =
+DIVO =
+DEBUG_FLAGS = -g
+
+FFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS) $(INCS)
+CFLAGS = $(FFLAGS) -Df2cFortran
+LINKFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS)
+
+# language-specific flags
+#
+F77FLG =
+F90FLG =

EnKF-MPI-TOPAZ/Config/make.hex.pathscale

@@ -0,0 +1,36 @@
+INC_NETCDF = 
+LIB_NETCDF= -lnetcdf
+LIB_LAPACK = -lacml
+
+INCS = $(INC_NETCDF)
+LIBS = $(LIB_LAPACK) $(LIB_NETCDF)
+
+CPPARCH = -DIA32 -DNOMPIR8
+CPPFLAGS = -P $(CPPARCH) -DF90_NOFLUSH
+
+ifeq ($(MPI),YES)
+	CF90 = ftn
+	PARO = -mp
+else
+	CF90 = ftn
+	PAR0 =
+endif
+CF77 = $(CF90)
+LD = $(CF90)
+CPP = /usr/bin/cpp -traditional-cpp
+
+SIZEO = -r8
+OPTO = -fullwarn
+ARCHO=
+INLO =
+DIVO= -byteswapio
+DEBUG_FLAGS =
+
+FFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS) $(INCS)
+CFLAGS = -DpgiFortran
+LINKFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS)
+
+# language-specific flags
+#
+F77FLG =  -fixedform            
+F90FLG = -freeform

EnKF-MPI-TOPAZ/Config/make.hex.pg

@@ -0,0 +1,47 @@
+LIB_NETCDF= -lnetcdf
+LIB_LAPACK = -lacml
+
+INCS = $(INC_NETCDF) $(INC_FFTW)
+LIBS = $(LIB_LAPACK) $(LIB_NETCDF) $(LIB_FFTW)
+
+ifeq ($(MPI),YES)
+	CF90 = ftn
+	PARO = -Mmpi=mpich -Mprof=dwarf -Minform=inform
+	CPPFLAGS = -DQMPI
+else
+	CF90 = ftn
+	PAR0 = 
+endif
+CF77 = $(CF90)
+CC = $(CF90)
+LD = $(CF90)
+CPP = /usr/bin/cpp -traditional-cpp -P
+
+CPPARCH = -DIA32 -DFFTW -DNOMPIR8
+CPPFLAGS += $(CPPARCH) -DF90_NOFLUSH
+
+SIZEO = -r8
+OPTO = -fast -fastsse
+ARCHO= -mcmodel=medium
+INLO =
+DIVO = -byteswapio
+DEBUG_FLAGS =
+
+# uncomment below for debugging and set MPI = NO in makefile
+#	CF90 = pgfortran
+#	DEBUG_FLAGS = -g -Minform=inform
+#	PAR0 =
+#	OPTO = 
+#	INC_NETCDF = -I/local/netcdf-3.6.2-pgi/include
+#	LIB_NETCDF = /local/netcdf-3.6.2-pgi/lib/libnetcdf.a
+#	INC_FFTW = -I/opt/fftw/3.2.2/include
+#	LIB_FFTW = /opt/fftw/3.2.2/lib/libfftw3.a
+
+FFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS) $(INCS)
+CFLAGS = $(FFLAGS) -DpgiFortran
+LINKFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS)
+
+# language-specific flags
+#
+F77FLG = -Mfixed                   
+F90FLG = -Mfree

EnKF-MPI-TOPAZ/Config/make.hex.pg.old

@@ -0,0 +1,38 @@
+INC_NETCDF = 
+LIB_NETCDF= -lnetcdf
+LIB_LAPACK = /home/nersc/pavelsa/local/lib/pg/lapack.a /home/nersc/pavelsa/local/lib/pg/tmglib.a /home/nersc/pavelsa/local/lib/pg/blas.a 
+
+INCS = $(INC_NETCDF)
+LIBS = $(LIB_LAPACK) $(LIB_NETCDF)
+
+ifeq ($(MPI),YES)
+	CF90 = ftn
+	PARO = -Mmpi -Mprof
+	CPPFLAGS = -DQMPI
+else
+	CF90 = ftn
+	PAR0 =
+endif
+CF77 = $(CF90)
+CC = $(CF90)
+LD = $(CF90)
+CPP = /usr/bin/cpp -traditional-cpp
+
+CPPARCH = -DIA32 -DFFTW -DNOMPIR8
+CPPFLAGS += -P $(CPPARCH) -DF90_NOFLUSH
+
+SIZEO = -r8
+OPTO =
+ARCHO=
+INLO =
+DIVO= -byteswapio
+DEBUG_FLAGS = -g -Minform=inform
+
+FFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS) $(INCS)
+CFLAGS = $(FFLAGS) -DpgiFortran
+LINKFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS)
+
+# language-specific flags
+#
+F77FLG = -Mfixed                   
+F90FLG = -Mfree

EnKF-MPI-TOPAZ/Config/make.mn3

@@ -0,0 +1,43 @@
+# Library and include
+
+INC_NETCDF = -I/apps/NETCDF/4.3.2/INTEL/IMPI/include
+LIB_NETCDF = -L/apps/NETCDF/4.3.2/INTEL/IMPI/lib    -lnetcdf -lnetcdff
+
+#LIB_LAPACK = -L/opt/intel/mkl/9.0/lib/em64t -lmkl_lapack -lmkl_em64t -lguide -lpthread
+LIB_LAPACK = -L/apps/LAPACK/3.4.2/INTEL/lib -llapack
+LIBBLAS = -L/apps/OPENBLAS/0.2.14/GCC/OPENMPI/lib -lblas
+
+INC_FFT = -I/gpfs/apps/MN3/FFTW/3.3/GCC+IMPI/include
+LIB_FFT = -I/gpfs/apps/MN3/FFTW/3.3/GCC+IMPI/lib -fftw3 -fftw3-mpi
+
+INCS = $(INC_NETCDF) $(INC_FFT)
+LIBS = $(LIB_LAPACK) $(LIBBLAS) $(LIB_NETCDF) $(INC_NETCDF) $(LIB_FFT)
+
+CF90 = /apps/INTEL/impi/4.1.3.049/intel64/bin/mpif90
+PARO =
+CPPFLAGS = -DQMPI
+CF77 = $(CF90)
+LD = $(CF90)
+CPP = /gpfs/apps/MN3/INTEL/2013_sp1.2.144/bin/fpp
+CC = /gpfs/apps/MN3/INTEL/2013_sp1.2.144/bin/icc
+
+CPPARCH = 
+CPPFLAGS += 
+
+SIZEO = -r8
+OPTO = -O3
+#ARCHO = -fno-second-underscore
+INLO =
+DIVO =
+DEBUG_FLAGS = -g -traceback -W1 -warn unused -warn uncalled -debug extended -debug-parameters -ftrapuv -fpe0
+
+FFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS) $(INCS)
+#CFLAGS = $(FFLAGS) -Df2cFortran
+CFLAGS = -O3  $(INCS)  # -r8 (seems to be default) -Df2cFortran $(INCS)
+LINKFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS) $(LIBS)
+
+# language-specific flags
+#
+F77FLG =
+F90FLG =
+

EnKF-MPI-TOPAZ/Config/make.mn4

@@ -0,0 +1,45 @@
+# Library and include
+
+INC_NETCDF = -I/apps/NETCDF/4.4.1.1/INTEL/IMPI/include
+LIB_NETCDF = -L/apps/NETCDF/4.4.1.1/INTEL/IMPI/lib -lnetcdf -lnetcdff
+
+#LIB_LAPACK = -L/opt/intel/mkl/9.0/lib/em64t -lmkl_lapack -lmkl_em64t -lguide -lpthread
+#LIB_LAPACK = -L/apps/LAPACK/3.4.2/INTEL/lib -llapack
+#LIBBLAS = -L/apps/OPENBLAS/0.2.14/GCC/OPENMPI/lib -lblas
+#LIB_LAPACK = -L/apps/INTEL/2017.4/mkl/lib/ -llapack
+#LIBBLAS = -L/apps/INTEL/2017.4/mkl/lib/ -lblas
+LIB_MKL = -L/apps/INTEL/2017.4/mkl/lib/intel64 -lmkl_rt
+INC_FFT = -I/gpfs/apps/MN3/FFTW/3.3/GCC+IMPI/include
+LIB_FFT = -I/gpfs/apps/MN3/FFTW/3.3/GCC+IMPI/lib -fftw3 -fftw3-mpi
+
+INCS = $(INC_NETCDF) $(INC_FFT)
+LIBS = $(LIB_NETCDF) $(INC_NETCDF) $(LIB_FFT) $(LIB_MKL) # $(LIB_LAPACK) $(LIBBLAS)
+
+CF90 = /apps/INTEL/2017.4/impi/2017.3.196/bin64/mpif90
+PARO =
+CPPFLAGS = -DQMPI
+CF77 = $(CF90)
+LD = $(CF90)
+CPP = /apps/INTEL/2017.4/bin/fpp
+CC = /apps/INTEL/2017.4/bin/icc
+
+CPPARCH =
+CPPFLAGS +=
+
+SIZEO = -r8
+OPTO = -O3
+#ARCHO = -fno-second-underscore
+INLO =
+DIVO =
+DEBUG_FLAGS = -g -traceback -W1 -warn unused -warn uncalled -debug extended -debug-parameters -ftrapuv -fpe0
+
+FFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS) $(INCS)
+#CFLAGS = $(FFLAGS) -Df2cFortran
+CFLAGS = -O3  $(INCS)  # -r8 (seems to be default) -Df2cFortran $(INCS)
+LINKFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS) $(LIBS)
+
+# language-specific flags
+#
+F77FLG =
+F90FLG =
+

EnKF-MPI-TOPAZ/Config/make.njord

@@ -0,0 +1,47 @@
+INC_NETCDF = -I/usr/local/netcdf/netcdf-3.6.2/include
+LIB_NETCDF= /usr/local/netcdf/netcdf-3.6.2/lib/libnetcdf.a
+LIB_LAPACK = /usr/local/lapack/lapack-3.0.20021004/lib/liblapack.a
+
+INCS = $(INC_NETCDF)
+LIBS = -lessl -lmass  $(LIB_LAPACK) $(LIB_NETCDF)
+
+CPPARCH = -DAIX -Df2cFortran
+CPPFLAGS += -P $(CPPARCH) -DF90_NOFLUSH -ansi
+
+ifeq ($(MPI),YES)
+	CF90 = mpxlf95_r
+	PARO = -qsmp=omp
+	CC = mpcc_r
+else
+	CF90 = xlf95_r
+	PAR0 =
+	CC = xlc
+endif
+CF77 = $(CF90)
+LD = $(CF90)
+CPP = cpp
+
+SIZEO = -b64 -q64 -qrealsize=8
+OPTO = -O2 -qstrict
+ARCHO= -qarch=auto -qtune=auto -qcache=auto
+INLO =
+DIVO= -qmaxmem=-1 -qnosave
+
+# Flags for debugging -- slow, gives location of SIGTRAP
+# -g        -- turns on debugging ...
+# -qfloat   -- options for floating point operations
+# -qflttrap -- Floating point operation traps
+# -qextchk  -- Checks if subroutine args are consistent + common block checks
+# -C        -- Checks array bounds 
+# qinitauto=FF initializes all vars to NaN -- So that uninitialized vars can be detected
+#DEBUG_FLAGS = -C -qflttrap=underflow:overflow:zerodivide:invalid:enable -qextchk -qinitauto=FF -qfloat=nofold:nohssngl:nans  -g
+DEBUG_FLAGS =
+
+FFLAGS = $(SIZEO) $(OPTO) $(ARCHO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS) $(INCS) 
+CFLAGS = -O2 -DpgiFortran
+LINKFLAGS = $(SIZEO) $(OPTO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS)  -bloadmap:load.out
+
+# language-specific flags
+#
+F77FLG = -qfixed                   
+F90FLG = -qsuffix=f=f90 -qfree=f90 

EnKF-MPI-TOPAZ/Config/make.tre

@@ -0,0 +1,120 @@
+#Compiler Options -- serial hands-off version
+#LD = xlf90_r -qspillsize=2152 
+#CF90 = xlf90_r  -qsuffix=f=f90 -qspillsize=2152 -qfree=f90
+#CF77 = xlf90_r -qfixed -qspillsize=2152
+#
+
+#Compiler -- F90
+#CF90 = /usr/bin/xlf95_r 
+CF90 = mpxlf95_r 
+
+#Compiler -- F77
+CF77 = /usr/bin/xlf90_r 
+CP77 = $(CF90)
+
+#Linker 
+#LD = /usr/bin/xlf95_r 
+LD = mpxlf95_r
+
+#Paralellization opts
+#PARO =
+PARO = -qsmp=omp
+
+#Size defaults
+SIZEO = -b64 -q64 -qrealsize=8
+
+#Arch opts
+ARCHO= -qarch=auto -qtune=auto -qcache=auto
+
+#Optimalization opts
+OPTO= -O3 -qstrict
+OPTO= -O2 -qstrict
+
+#Inlining opts
+#INLO= -Q -qipa
+INLO=
+
+# Diverse options
+DIVO= -qmaxmem=-1 -qnosave -I/usr/local/NetCDF/include
+
+
+
+
+# Flags for debugging -- slow, gives location of SIGTRAP
+# -g        -- turns on debugging ...
+# -qfloat   -- options for floating point operations
+# -qflttrap -- Floating point operation traps
+# -qextchk  -- Checks if subroutine args are consistent + common block checks
+# -C        -- Checks array bounds 
+# qinitauto=FF initializes all vars to NaN -- So that uninitialized vars can be detected
+#
+#DEBUG_FLAGS = -C -qflttrap=underflow:overflow:zerodivide:invalid:enable  \
+#              -qextchk -qinitauto=FF -qfloat=nofold:nohssngl:nans  -g
+
+
+# version without qfloat shoul allow for stmt_func
+#         without qextchk which allows for inconsistent interfaces 
+#         qextchk notes the different declarations of a in analysis(A,...)
+#DEBUG_FLAGS = -C -qflttrap=overflow:zerodivide:invalid:enable -qinitauto=FF -g -qfullpath \
+#              -qinitauto=FF	 
+#DEBUG_FLAGS = -qflttrap=underflow:overflow:zerodivide:invalid:enable  -qfullpath
+DEBUG_FLAGS = -pg
+
+
+F77FLG = -qextname -qfixed                   
+F90FLG = -qextname -qsuffix=f=f90 -qfree=f90 
+
+
+FFLAGS    = $(SIZEO) $(OPTO) $(ARCHO) $(PARO)    $(INLO) $(DIVO) $(DEBUG_FLAGS) 
+LINKFLAGS = $(SIZEO) $(OPTO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS)  -bloadmap:load.out  -brename:.dgesvd_,.dgesvd
+
+
+
+
+
+CPPARCH = -DPWR4 -DAIX
+CPPFLAGS =  -P $(CPPARCH) 
+#LIBS = -lessl /home/parallab/nersc/knutali/lib/liblapack64.a
+LIBS = -lessl -lmass -L /usr/local/lib/ -llapack -L /usr/local/NetCDF/lib/ -lnetcdf
+#LIBS = -lessl -L /usr/local/lib/ -llapack -L /usr/local/NetCDF/lib/ -lnetcdf
+
+
+CPP = /usr/lib/cpp
+
+
+
+
+
+all: $(TARGET) 
+
+
+$(TARGET): $(INC2) $(OMOD) $(OBJECTS)  $(OMP_EXCEPTION_OBJ77) $(OMP_EXCEPTION_OBJ90)
+	cd ./TMP ; $(LD) $(LINKFLAGS) -o ../$(TARGET) $(OMOD) $(OBJECTS) $(LIBS) -brename:.dgesvd_,.dgesvd 
+
+
+#################################################################################
+OBJECTS1 =  p_test.o mod_states.o mod_dimensions.o m_testref.o
+$(TARGET1): $(OBJECTS1) $(OMOD) 
+	cd ./TMP ; $(LD) $(LINKFLAGS) -o ../$(TARGET1) $(OBJECTS1) 
+
+#################################################################################
+OBJECTS2 = mod_raw_io.o m_parse_blkdat.o p_EnKF_postprocess.o 
+$(TARGET2): $(OBJECTS2)  
+	cd ./TMP ; $(LD) $(LINKFLAGS) -o ../$(TARGET2) $(OBJECTS2) 
+
+#################################################################################
+
+clean:
+	cd ./TMP ; rm *.f  *.o *.f90 *.h *.mod
+
+
+new: source depend
+
+source:
+	./mksource.sh > source.files
+
+depend:
+	./mkdepend.pl | sort -u > depends.file
+
+include depends.file
+

EnKF-MPI-TOPAZ/Config/make.ve

@@ -0,0 +1,87 @@
+# Knuts home directory (contains some libs/includes)
+#KHOME = /home/fimm/nersc/knutali/
+KHOME = 
+
+#Compiler -- F90
+CF90 = ifort
+#CF90 = /local/openmpi/bin/mpif90
+
+#Compiler -- F77
+CF77 = $(CF90)
+
+# Compiler -- C
+CC=icc
+#CC=/local/openmpi/bin/mpicc
+
+#Linker 
+LD =  $(CF90)
+
+
+#Paralellization opts
+PARO = -lmpi 
+#PARO = 
+
+#Size defaults - Change to real_size 64 for default double...
+SIZEO = -real_size 64 -double_size 64
+#SIZEO = 
+
+#Arch opts
+ARCHO= 
+
+#Optimalization opts
+#OPTO= 
+OPTO= -O3 -xSSE4.2
+
+#Inlining opts
+INLO= -ip
+#INLO=
+
+
+# Diverse options -swap endian IO -use medium memory model
+DIVO= -convert big_endian -shared-intel -mcmodel=medium
+
+# Flags for debugging. Empty optimization (OPTO above) to use debugging properly
+#
+#DEBUG_FLAGS = -g  -check bounds -fpstkchk -traceback -fpe0 
+#DEBUG_FLAGS = -g  -check all -traceback -fpe0  -CA -CB -CS -CU -CV
+DEBUG_FLAGS = -g -cm -vec_report0 -w
+
+
+
+CFLAGS = -O -shared-intel -mcmodel=medium
+F77FLG = -fixed
+F90FLG = -free
+
+# C preprocessor
+CPP = cpp -P
+#CPP = /usr/bin/cpp
+
+#CPP flags 
+#CPPARCH = -traditional -DIA32 -DFFTW
+#CPPARCH = #-DIA32 -DREAL8 -DSERIAL_IO -DTIMER -DFFTW #-DENDIAN_IO
+CPPARCH = -DF90_NOFLUSH #-DIA32 -DREAL8 -DSERIAL_IO -DTIMER -DFFTW #-DENDIAN_IO
+CPPFLAGS = -P $(CPPARCH) -ansi -DQMPI 
+
+#This uses the OpenMPI implementation of mpi-2
+#LIBS =  -L/local/netcdf/lib/ -lnetcdf  -L/local/openmpi/lib/ -lmpi \
+#        -L/local/fftw/lib/ -lfftw3   \
+#        -L/local/acml/ifort64/lib/ -lacml_mv -lacml -lg2c
+LIBS =  -mkl=sequential #parallel \
+#        -L/prod/forecast/opt/lib -lfftw3
+#        -L/store/hengedahl/lib/fftw-3.3/out/lib -lfftw3 \
+#        -L/store/tuccillo/libs/netcdf-3.6.2/lib -lnetcdf
+
+# Include dir for header and module files
+#INCLUDEDIR= -I/local/netcdf/include -I/local/fftw/include \
+#-I/local/openmpi/include
+#INCLUDEDIR=  -I/store/hengedahl/lib/fftw-3.3/out/include \
+INCLUDEDIR=  
+# -I/sw/sdev/Modules/netcdf/netcdf-3.6.2/include/
+#             -I/store/tuccillo/libs/netcdf-3.6.2/include
+
+
+# Put together flags
+FFLAGS    = $(SIZEO) $(OPTO) $(ARCHO) $(PARO)    $(INLO) $(DIVO) $(DEBUG_FLAGS) $(INCLUDEDIR)
+LINKFLAGS = $(SIZEO) $(OPTO) $(PARO) $(INLO) $(DIVO) $(DEBUG_FLAGS)  \
+            -lnetcdff -lnetcdf -lmpi
+

EnKF-MPI-TOPAZ/EnKF.F90

@@ -0,0 +1,330 @@
+! File:          EnKF.F90
+!
+! Created:       ???
+!
+! Last modified: 20/04/2010
+!
+! Purpose:       Main program for EnKF analysis
+!
+! Description:   The workflow is as follows:
+!                -- read model parameters
+!                -- read obs
+!                -- conduct necessary pre-processing of obs (superobing)
+!                -- calculate ensemble observations
+!                -- calculate X5
+!                -- update the ensemble
+!
+! Modifications:
+!                20/9/2011 PS:
+!                  Modified code to allow individual inflations for each of
+!                  `NFIELD' fields updated in a batch - thanks to Ehouarn Simon
+!                  for spotting this inconsistency
+!                6/8/2010 PS:
+!                  Small changes in calls to calc_X5() and update_fields() to
+!                  reflect changes in interfaces.
+!                6/7/2010 PS:
+!                  Moved point output to a separate module m_point2nc.F90
+!                25/5/2010 PS:
+!                  Added inflation as a 4th command line argument
+!                20/5/2010 PS:
+!                  Set NFIELD = 4. This requires 4 GB per node in TOPAZ and
+!                  "medium" memory model on Hexagon (a single allocation for a
+!                   variable over 2GB)
+!                20/4/2010 PS:
+!                  Set NFIELD = 4. This will require 2 GB per node in TOPAZ.
+!                  Thanks to Alok Gupta for hinting this possibility.
+!                10/4/2010 PS:
+!                  Moved variable `field' from real(8) to real(4);
+!                  set NFIELD = 2.
+!                Prior history:
+!                  Not documented.
+!                15/4/2016 Francois Massonnet (FM): Make changes to be
+!                          NEMO-compliant. Targeted for NEMO3.6 at BSC,
+!                          Barcelona, but based on previous experience
+!                          at UCL and on work from Chris Konig-Beaty [CKB]
+
+program EnKF
+#if defined(QMPI)
+  use qmpi
+#else
+  use qmpi_fake
+#endif
+  use m_parameters
+  use distribute
+  use mod_measurement
+  use m_get_mod_grid
+  use m_get_mod_nrens
+  use m_get_mod_xyz ! Added by Francois Massonnet [FM] May 2013 and Apr 2016 !
+  use m_obs
+  use m_local_analysis
+  use m_prep_4_EnKF
+  use m_set_random_seed2
+  !use m_get_mod_fld  ! Taken out and simplified by m_io_mod_fld
+  !use m_put_mod_fld
+  use m_io_mod_fld    ![CKB,FM] was: m_get_mod_fld and m_put_mod_fld
+  use mod_analysisfields
+  use m_parse_blkdat
+  use m_random
+  use m_point2nc
+  implicit none
+
+  character(*), parameter :: ENKF_VERSION = "2.11"
+
+  integer, external :: iargc
+
+  ! NFIELD is the number of fields (x N) passed for the update during a call to
+  ! update_fields(). In TOPAZ4 NFIELD = 2 if there is 1 GB of RAM per node, and
+  ! NFIELD = 4 if there are 2 GB of RAM. Higher value of NFIELD reduces the
+  ! number of times X5tmp.uf is read from disk, which is the main bottleneck
+  ! for the analysis time right now.
+  !
+  integer, parameter :: NFIELD = 8
+
+  character(512) :: options
+
+  integer :: nrens
+  integer, allocatable, dimension(:) :: enslist ! [FM] List of existing
+                                                ! ensemble members
+  real, allocatable, dimension(:,:) :: modlon, modlat, depths, readfld
+  real, allocatable, dimension(:,:) :: S ! ensemble observations HE
+  real, allocatable, dimension(:)   :: d ! d - Hx
+
+  integer k, m
+
+  ! "New" variables used in the parallelization 
+  integer, dimension(:,:), allocatable :: nlobs_array
+  real(4), allocatable :: fld(:,:)
+  real(8) rtc, time0, time1, time2
+
+  ! Additional fields
+  character(len=3) :: cmem
+  character(len=80) :: memfile
+  integer :: fieldcounter
+
+  character(100) :: text_string
+
+  real :: rdummy
+  integer :: idm, jdm, kdm
+
+  real :: mindx
+  real :: meandx
+  integer :: m1, m2, nfields
+  real :: infls(NFIELD)
+
+#if defined(QMPI)
+  call start_mpi()
+#endif
+
+  ! Read the characteristics of the assimilation to be carried out.
+
+  if (iargc() /= 1) then
+     print *, 'Usage: EnKF <parameter file>'
+     print *, '       EnKF -h'
+     print *, 'Options:'
+     print *, '  -h -- describe parameter fie format'
+     call stop_mpi()
+  else
+    call getarg(1, options)
+    if (trim(options) == "-h") then
+       call prm_describe()
+       call stop_mpi()
+    end if
+  end if
+
+  if (master) then
+     print *
+     print '(a, a)', ' EnKF version ', ENKF_VERSION
+     print *
+  end if
+
+  call prm_read()
+  call prm_print()
+
+  ! get model dimensions
+  !
+   ! Change FM May 2013. Goal is to avoid using parse_blkdat that requires a 
+   ! file with unknown format
+
+   !call parse_blkdat('idm   ', 'integer', rdummy, idm)
+   !call parse_blkdat('jdm   ', 'integer', rdummy, jdm)
+   !call parse_blkdat('kdm   ', 'integer', rdummy, kdm)
+
+   CALL get_mod_xyz(idm, jdm, kdm)
+   WRITE(*,*), 'The model dimensions are ', idm,jdm,kdm
+   ! End Change FM May 2013. 
+
+   allocate(modlon(idm, jdm))
+   allocate(readfld(idm, jdm))
+   allocate(modlat(idm, jdm))
+   allocate(depths(idm, jdm))
+   allocate(nlobs_array(idm, jdm))
+
+   ! get model grid
+   !
+   call get_mod_grid(modlon, modlat, depths, mindx, meandx, idm, jdm)
+
+   ! set a variable random seed
+   !
+   call set_random_seed2
+
+   ! initialise point output
+   !
+   call p2nc_init
+
+   time0 = rtc()
+
+   ! read measurements
+   !
+   if (master) then
+      print *, 'EnKF: reading observations'
+   end if
+   call obs_readobs
+   if (master) then
+      print '(a, i6)', '   # of obs = ', nobs
+      print '(a, a, a, e10.3, a, e10.3)', '   first obs = "', trim(obs(1) % id),&
+           '", v = ', obs(1) % d, ', var = ', obs(1) % var
+      print '(a, a, a, e10.3, a, e10.3)', '   last obs = "', trim(obs(nobs) % id),&
+           '", v = ', obs(nobs) % d, ', var = ', obs(nobs) % var
+   end if
+   if (master) then
+      print *
+   end if
+
+   ! read ensemble size and store in A
+   !
+   ! [CKB,FM] changed 
+   call get_mod_nrens(nrens)
+   allocate( enslist(nrens) )
+   call get_mod_nrens(nrens, enslist)
+
+   ! end [CKB, FM]
+   if (master) then
+      print '(a, i4, a)', ' EnKF: ', nrens, ' ensemble members found'
+   end if
+   if (ENSSIZE > 0) then
+      ENSSIZE = min(nrens, ENSSIZE)
+   else
+      ENSSIZE = nrens
+   end if
+   if (master) then
+      print '(a, i4, a)', ' EnKF: ', ENSSIZE, ' ensemble members used'
+   end if
+   if (master) then
+      print *
+   end if
+
+   ! PS - preprocess the obs using the information about the ensemble fields
+   ! here (if necessary), before running prep_4_EnKF(). This is necessary e.g.
+   ! for assimilating in-situ data because of the dynamic vertical geometry in
+   ! HYCOM
+   !
+   call obs_prepareobs
+
+   allocate(S(nobs, ENSSIZE), d(nobs))
+   call prep_4_EnKF(ENSSIZE,enslist, d, S, depths, meandx / 1000.0, idm, jdm, kdm)
+   if (master) then
+      print *, 'EnKF: finished initialisation, time = ',  rtc() - time0
+   end if
+
+   ! (no parallelization was required before this point)
+
+   time1 = rtc()
+
+   allocate(X5(ENSSIZE, ENSSIZE, idm))
+   allocate(X5check(ENSSIZE, ENSSIZE, idm))
+   call calc_X5(ENSSIZE, modlon, modlat, depths, mindx, meandx, d, S,&
+        LOCRAD, RFACTOR2, nlobs_array, idm, jdm)
+   deallocate(d, S, X5check)
+   if (master) then
+      print *, 'EnKF: finished calculation of X5, time = ', rtc() - time0
+   end if
+
+   allocate(fld(idm * jdm, ENSSIZE * NFIELD))
+
+#if defined(QMPI)
+   call barrier()
+#endif
+
+   ! get fieldnames and fieldlevels
+   !
+   call get_analysisfields()
+
+   call distribute_iterations(numfields)
+#if defined(QMPI)
+   call barrier() !KAL - just for "niceness" of output
+#endif
+   time2 = rtc()
+   do m1 = my_first_iteration, my_last_iteration, NFIELD
+      m2 = min(my_last_iteration, m1 + NFIELD - 1)
+      nfields = m2 - m1 + 1
+
+      do m = m1, m2
+         print '(a, i2, a, i3, a, a6, a, i3, a, f11.0)',&
+              "I am ", qmpi_proc_num, ', m = ', m, ", field = ",&
+              fieldnames(m), ", k = ", fieldlevel(m), ", time = ",&
+              rtc() - time2
+         do k = 1, ENSSIZE
+            write(cmem, '(i3.3)') k
+            memfile = 'forecast' // cmem
+            !call get_mod_fld_new(trim(memfile), readfld, k, fieldnames(m),&
+            !     fieldlevel(m), 1, idm, jdm)
+            ! [CKB,FM]
+            call io_mod_fld(readfld, k, enslist,fieldnames(m),fieldtype(m), &
+              fieldlevel(m), 1, idm, jdm, 'get',FLOAT(obs(1)%date))
+            ! end CKB,FM
+            ! reshaping and conversion to real(4)
+            fld(:, ENSSIZE * (m - m1) + k) = reshape(readfld, (/idm * jdm/))
+         end do
+         call p2nc_storeforecast(idm, jdm, ENSSIZE, numfields, m, fld(:, ENSSIZE * (m - m1) + 1 : ENSSIZE * (m + 1 - m1)))
+         infls(m - m1 + 1) = prm_getinfl(trim(fieldnames(m)));
+      end do
+
+      call update_fields(idm, jdm, ENSSIZE, nfields, nlobs_array, depths,&
+              fld(1,1), infls)
+
+      do m = m1, m2
+         fieldcounter = (m - my_first_iteration) + 1
+         do k = 1, ENSSIZE
+            write(cmem,'(i3.3)') k
+            memfile = 'analysis' // cmem
+            ! reshaping and conversion to real(8)
+            readfld = reshape(fld(:, ENSSIZE * (m - m1) + k), (/idm, jdm/))
+            write(text_string, '(a, i3.3)') '_proc', qmpi_proc_num
+            !call put_mod_fld(trim(memfile) // trim(text_string), readfld, k,&
+            !     fieldnames(m), fieldlevel(m), 1, fieldcounter, idm, jdm)
+            ! [FM,CKB]
+            call io_mod_fld(readfld, k, enslist, fieldnames(m), fieldtype(m), &
+              fieldlevel(m), 1, idm, jdm, 'put',FLOAT(obs(1)%date))
+            ! end FM,CKB
+         end do
+      end do
+   end do
+   deallocate(X5)
+   deallocate(fld)
+
+   call p2nc_writeforecast
+
+   ! Barrier only necessary for timings
+#if defined(QMPI)
+   call barrier()
+#endif
+   if (master) then
+      print *, 'EnKF: time for initialization = ', time1 - time0
+      print *, 'EnKF: time for X5 calculation = ', time2 - time1
+      print *, 'EnKF: time for ensemble update = ', rtc() - time2
+      print *, 'EnKF: total time = ', rtc() - time0
+   end if
+   print *, 'EnKF: Finished'
+   call stop_mpi()
+ end program EnKF
+
+#if defined(_G95_)
+ ! not tested! - PS
+ !
+ real function rtc()
+   integer :: c
+
+   call system_clock(count=c)
+   rtc = dfloat(c)
+ end function rtc
+#endif

EnKF-MPI-TOPAZ/MODEL.CPP

@@ -0,0 +1,9 @@
+#undef TEST_2D
+#undef LINUX
+#undef DEBUG
+#undef TEST_1D
+#define ICE
+#define SINGLE_RESTART 
+#define EXPCOV
+#undef CHECK_SOLUTION
+#undef X4SVD

EnKF-MPI-TOPAZ/Prep_Routines/MODEL.CPP

@@ -0,0 +1,2 @@
+#undef QMPI
+#define LITTLE_ENDIAN

EnKF-MPI-TOPAZ/Prep_Routines/byteswapper.F90

@@ -0,0 +1,48 @@
+      subroutine swapendian(a)
+      implicit none
+      integer(kind=8), intent(inout) :: a  ! 4-bytes
+
+      integer(kind=8) ii4,   io4     ! 4-bytes
+      common/czioxe/  ii4,   io4     ! helps prevent unwanted optimization
+      save  /czioxe/
+      integer(kind=1) ii1(8),io1(8)  ! 1-byte
+      equivalence    (ii4,ii1(1)), (io4,io1(1))  ! non-standard f90
+
+        ii4 = a
+        io1(1) = ii1(8)
+        io1(2) = ii1(7)
+        io1(3) = ii1(6)
+        io1(4) = ii1(5)
+        io1(5) = ii1(4)
+        io1(6) = ii1(3)
+        io1(7) = ii1(2)
+        io1(8) = ii1(1)
+        a = io4
+      return
+      end subroutine swapendian
+
+      subroutine swapendian2(a,n)
+      implicit none
+      integer        , intent(in)    :: n    ! Size of input type to convert
+
+      ! NB - input can be anything - can not be compiled with input argument checking
+      integer(kind=1), intent(inout) :: a(n) 
+
+      integer k
+      integer(kind=1) ii4(16),   io4(16)     ! 16 bytes should beenough for everyone
+      !common/czioxe/  ii4,   io4     ! helps prevent unwanted optimization
+      !save  /czioxe/
+      !integer(kind=1) ii1(16),io1(16)  ! 1-byte
+      !equivalence    (ii4(1),ii1(1)), (io4(1),io1(1))  ! non-standard f90
+
+        ii4(1:n) = a
+
+        do k=1,n
+           !io1(k) = ii1(n-k+1)
+           io4(k) = ii4(n-k+1)
+        end do
+
+        a = io4(1:n)
+      return
+      end subroutine swapendian2
+

EnKF-MPI-TOPAZ/Prep_Routines/m_get_def_wet_point.F90

@@ -0,0 +1,162 @@
+! Bilinear coeffisients are calculated witin this program for all the 
+! observation points.
+! Only wet points are stored in the observation.uf file
+
+module m_get_def_wet_point
+
+  implicit none
+
+  integer, parameter, private :: STRLEN = 512
+  character(STRLEN), parameter, private :: MEANSSHFNAME = "meanssh.uf"
+  
+  private read_mean_ssh
+  private land_nearby
+
+contains 
+
+  subroutine get_def_wet_point(obs, data, gr, depths, modlat, modlon, nrobs, nx, ny)
+    ! Program converts to a general format readable by ENKF (observations.uf)
+    use mod_measurement
+    use mod_grid
+    ! Functions to be used
+    use m_oldtonew
+    use m_bilincoeff
+    use m_pivotp
+    use m_confmap
+    use m_spherdist
+
+    integer, intent(in) :: nx, ny
+    type (measurement), intent(in) :: data(:)
+    type (measurement), intent(inout)   :: obs(:)
+    type (grid), intent(in) :: gr      ! observations grid
+    real, dimension(nx, ny), intent(in)  ::  depths, modlat, modlon
+    integer, intent(out) :: nrobs
+    integer, parameter :: maxobs = 1441 * 722 !2*400*600 ! maximum number of observations
+
+    real, dimension(nx, ny) :: mean_ssh
+    integer k, imin, imax, jmin, jmax
+    integer ipiv, jpiv, nsupport, nsmin, nsmax
+    real :: x0, y0
+    real wetsill, griddiag, mingridsize, minobssize
+
+    logical wet
+
+    ! gr = default_grid
+    nrobs = 0; 
+    nsmin = maxobs; 
+    nsmax = 0
+    mingridsize = 1.E+10; 
+    minobssize = 1.E+10    ! in meters
+
+    call confmap_init(nx,ny) ! Initialize conformal mapping before calling
+
+    !Calculate pivot points
+    !Find wet points (all neigbours in water)
+    !Find the points with defined data value
+    !Put the data into the obs data structture
+    !Compute bilinear coefficients
+
+    call read_mean_ssh(mean_ssh, nx, ny)
+
+    do k = 1, gridpoints(gr)
+       if (data(k) % id .eq. 'SLA' .or. data(k) % id .eq. 'sla' .or. &
+            data(k) % id.eq. 'SSH' .or. data(k)%id .eq. 'ssh' .or.&
+            data(k)%id.eq.'TSLA') then
+          wetsill = 200.   ! Discarding data in shallow waters
+       else
+          wetsill=10.
+       endif
+       call oldtonew(data(k) % lat, data(k) % lon, y0, x0)
+       call pivotp(x0, y0, ipiv, jpiv)
+       ! Discard obs on model boundaries (TODO: cyclic domains) 
+       ! Also valid if ns=0 
+       imin = ipiv - data(k) % ns
+       imax = ipiv + data(k) % ns + 1 
+       jmin = jpiv - data(k) % ns
+       jmax = jpiv + data(k) % ns + 1
+       if ((imin .le. 0) .or. (jmin .le. 0) .or. (imax .ge. nx) .or. &
+            (jmax .ge. ny)) cycle
+       ! Is observation surrounded by wet grid points?
+       if (any(depths(imin:imax, jmin:jmax) < wetsill .or. depths(imin:imax, jmin:jmax) == depths(imin:imax, jmin:jmax) + 1.0)) cycle
+       wet = data(k) % status ! Discards inconsistent/Fill values
+       if (data(k) % id .eq. 'SLA' .or. data(k) % id .eq. 'sla' .or.&
+            data(k) % id .eq. 'TSLA') then
+          wet = wet .and. (mean_ssh(ipiv, jpiv) < 990)
+          wet = wet .and. .not. land_nearby(nx, ny, mean_ssh, modlon, modlat,&
+               ipiv, jpiv, data(k) % lon, data(k) % lat)
+       endif
+
+       if(.not. undefined(data(k) % d, gr) .and. wet) then
+          nrobs = nrobs + 1
+          obs(nrobs) = data(k)
+          obs(nrobs) % ipiv = ipiv
+          obs(nrobs) % jpiv=  jpiv
+          obs(nrobs) % status = .true. ! Wet obs
+          if (data(k) % ns > 0) then   ! large support data: a1 is the obs support(m)
+             griddiag = spherdist(modlon(ipiv, jpiv), modlat(ipiv, jpiv), &
+                  modlon(ipiv + 1, jpiv + 1), modlat(ipiv + 1, jpiv + 1))
+             !FC: 0.5 because m_Generate_element_Si runs from -ns to +ns 
+             nsupport = floor(0.5 * data(k) % a1 / griddiag) ! both in meters
+             obs(nrobs)%ns = nsupport  ! number of grid cells in the diagonal
+             nsmin = min(nsmin, nsupport)
+             nsmax = max(nsmax, nsupport)
+             mingridsize = min(mingridsize, griddiag)
+             minobssize = min(minobssize, data(k) % a1)
+          else
+             obs(nrobs) % ns = 0    ! point measurements have zero support
+          endif
+          call bilincoeff(modlon, modlat, nx, ny, obs(nrobs)%lon, &
+               obs(nrobs) % lat, obs(nrobs) % ipiv, obs(nrobs) % jpiv, &
+               obs(nrobs) % a1, obs(nrobs) % a2, obs(nrobs) % a3, &
+               obs(nrobs) % a4)
+       endif
+    end do
+    print*, 'Number of defined and wet observations: nrobs ', nrobs
+    print*, 'Support (in nb of cells) between: ', nsmin, ' and ', nsmax
+    print '(2(a,f8.3),a)', ' Minimum obs support: ', 0.001 * minobssize, &
+         'km, min grid diagonal: ', 0.001 * mingridsize, ' km' 
+  end subroutine get_def_wet_point
+
+
+  subroutine read_mean_ssh(mean_ssh, nx, ny)
+    integer, intent(in) :: nx, ny
+    real, intent(out):: mean_ssh(nx, ny)
+    logical :: exists
+
+    inquire(file = trim(MEANSSHFNAME), exist = exists)
+    if (.not. exists) then
+       print *,'ERROR: read_mean_ssh(): file "', trim(MEANSSHFNAME), '" not found'
+       stop
+    end if
+       
+    open (10, file = trim(MEANSSHFNAME), status = 'unknown',form = 'unformatted')
+    read (10) mean_ssh
+    close (10)
+  end subroutine read_mean_ssh
+
+
+  logical function land_nearby(nx, ny, mean_ssh, modlon, modlat, ipiv, jpiv, obslon, obslat)
+    use m_spherdist
+    implicit none
+    real, parameter :: Dis0 = 50.0d0
+    integer, intent (in) :: nx, ny, ipiv, jpiv
+    real, dimension(nx,ny), intent(in) :: mean_ssh, modlon, modlat
+    real, intent (in) :: obslon,obslat 
+    integer :: ii, jj, ncells
+    real :: griddist
+
+    land_nearby = .false.
+    ncells = ceiling(Dis0 / spherdist(modlon(ipiv, jpiv), modlat(ipiv, jpiv),&
+         modlon(ipiv, jpiv + 1), modlat(ipiv, jpiv + 1)))
+    do jj = max(jpiv - ncells, 1), min(jpiv + ncells, ny)
+       do ii = max(ipiv - ncells, 1), min(ipiv + ncells, nx)
+          griddist = spherdist(modlon(ii, jj), modlat(ii, jj), obslon, obslat)
+          if (mean_ssh(ipiv,jpiv) < 990 .and. griddist < Dis0) then
+             land_nearby = .true.
+             return
+          end if
+       enddo
+    enddo
+  end function land_nearby
+
+end module m_get_def_wet_point

EnKF-MPI-TOPAZ/Prep_Routines/m_nf90_err.F90

@@ -0,0 +1,25 @@
+module m_nf90_err
+contains
+
+   subroutine nf90_err(errcode,chars)
+      use netcdf
+      implicit none
+      integer, intent(in) :: errcode
+      character(len=*), optional :: chars
+      character(len=80) :: hint
+
+
+      hint =''
+      if (present(chars)) hint=chars
+
+
+      if (errcode/=NF90_NOERR) then
+         write(6,'(a)') NF90_STRERROR(errcode)//'  '//trim(hint)
+         stop '(handle_err)'
+      end if
+
+   end subroutine
+
+
+
+end module m_nf90_err

EnKF-MPI-TOPAZ/Prep_Routines/m_read_CERSAT_data.F90

@@ -0,0 +1,191 @@
+module m_read_CERSAT_data
+
+contains
+
+  subroutine read_CERSAT_data(driftfile, gr, data, numdata, var)
+    use nfw_mod
+    use mod_measurement
+    use mod_grid
+    use m_spherdist
+    implicit none
+
+    character(*), intent(in) :: driftfile
+    integer, intent(in) :: numdata
+    type(measurement), dimension(numdata) :: data
+    type(grid), intent(in) :: gr
+    real, intent(in) :: var
+
+    integer :: dimids(2)
+    integer , dimension(2) :: dimsizes
+
+    integer :: lon_id, lat_id, zon_id, mer_id, qua_id
+    real, dimension(:,:), allocatable :: drlon, drlat, drmer, drzon
+    integer, dimension(:,:), allocatable :: qflag
+
+    integer :: ncid, varid
+    real, dimension(1) :: scalefac, fillval, addoffset
+
+    integer :: i,j,k,icomp
+    integer :: drnx, drny
+    logical :: valid
+    integer :: tmpint, bit(0:8)
+
+    ! Get dimensions of drift file
+    call nfw_open(driftfile, nf_nowrite, ncid)
+    call nfw_inq_varid(driftfile, ncid, 'zonal_motion', varid)
+    call nfw_inq_vardimid(driftfile, ncid, varid, dimids)
+    do i = 1, 2
+       call nfw_inq_dimlen(driftfile, ncid, dimids(i), dimsizes(i))
+    end do
+
+    if (gr % reg) then
+       print *,'NB: CERSAT data should be specified as irregular !'
+       print *,'    Currently it is set as regular..'
+       print *,'(read_CERSAT_data)'
+       call exit(1) 
+    end if
+
+    ! Which should match numdata dimension 
+    ! NB !!! Mult by 2 for two vector components
+    if (2 * dimsizes(1) * dimsizes(2) /= numdata .or. &
+         gr % nx /= dimsizes(1) * dimsizes(2) * 2) then
+       print *,'Different dimensions - data file and specified'
+       print *,'dimsizes(1)=',dimsizes(1)
+       print *,'dimsizes(2)=',dimsizes(2)
+       print *,'nx         =',gr%nx
+       print *,'(read_CERSAT_data)'
+       call exit(1) 
+    end if
+
+    ! Read data from drift file
+    drnx=dimsizes(1)
+    drny=dimsizes(2)
+    allocate(drlon(drnx,drny))
+    allocate(drlat(drnx,drny))
+    allocate(drmer(drnx,drny))
+    allocate(drzon(drnx,drny))
+    allocate(qflag(drnx,drny))
+    call nfw_inq_varid(driftfile, ncid, 'longitude', lon_id)
+    !call nfw_get_var_double(driftfile, ncid, lon_id, drlon)
+    call cersat_readfield(driftfile, ncid, lon_id, drlon, drnx * drny)
+    call nfw_inq_varid(driftfile, ncid, 'latitude', lat_id)
+    !call nfw_get_var_double(driftfile, ncid, lat_id, drlat)
+    call cersat_readfield(driftfile, ncid, lat_id, drlat, drnx * drny)
+    call nfw_inq_varid(driftfile, ncid, 'zonal_motion', zon_id)
+    !call nfw_get_var_double(driftfile, ncid, zon_id, drzon)
+    call cersat_readfield(driftfile, ncid, zon_id, drzon, drnx * drny)
+    call nfw_inq_varid(driftfile, ncid, 'meridional_motion', mer_id)
+    !call nfw_get_var_double(driftfile, ncid, mer_id, drmer)
+    call cersat_readfield(driftfile, ncid, mer_id, drmer, drnx * drny)
+
+    call nfw_get_att_double(driftfile, ncid, zon_id, '_FillValue', fillval)
+    call nfw_get_att_double(driftfile, ncid, zon_id, 'scale_factor', scalefac)
+    call nfw_get_att_double(driftfile, ncid, zon_id, 'add_offset', addoffset)
+
+    where (abs(drzon - (fillval(1) * scalefac(1) + addoffset(1))) <&
+         1e-4 * fillval(1) * scalefac(1) + addoffset(1))
+       drzon = gr % undef
+    end where
+
+    call nfw_get_att_double(driftfile, ncid, mer_id, '_FillValue', fillval)
+    call nfw_get_att_double(driftfile, ncid, mer_id, 'scale_factor', scalefac)
+    call nfw_get_att_double(driftfile, ncid, mer_id, 'add_offset', addoffset)
+
+    ! Flag zonal motion for fill values
+    where (abs(drmer - (fillval(1) * scalefac(1) + addoffset(1))) <&
+         1e-4 * fillval(1) * scalefac(1) + addoffset(1))
+       drmer = gr % undef
+    end where
+
+    call nfw_inq_varid(driftfile, ncid, 'quality_flag', qua_id)
+    call nfw_get_var_int(driftfile, ncid, qua_id, qflag)
+
+    call nfw_close(driftfile, ncid)
+
+    k = 0
+    do icomp = 1, 2
+       do j = 1, drny ! gr%ny
+          do i = 1, drnx ! gr%nx
+             k = k + 1
+
+             ! Qualit flag bits - may be signed 
+             tmpint = qflag(i,j)
+             bit(7) = tmpint/128;  tmpint = tmpint - bit(7)*128 ! Not used
+             bit(6) = tmpint/ 64;  tmpint = tmpint - bit(6)* 64 ! Validated using all available info
+             bit(5) = tmpint/ 32;  tmpint = tmpint - bit(5)* 32 ! Validated using local consistency
+             bit(4) = tmpint/ 16;  tmpint = tmpint - bit(4)* 16 ! Cost function used
+             bit(3) = tmpint/  8;  tmpint = tmpint - bit(3)*  8 ! Two identical drift vectors
+             bit(2) = tmpint/  4;  tmpint = tmpint - bit(2)*  4 ! SSMI V selected
+             bit(1) = tmpint/  2;  tmpint = tmpint - bit(1)*  2 ! SSMI H used
+             bit(0) = tmpint/  1;  tmpint = tmpint - bit(0)*  1 ! Quickscat used
+             
+             valid = qflag(i,j) < 127 ! Intermediate solution until I figure out the byte stuff
+             if (icomp==1) then
+                data(k)%id = 'VICE'
+                data(k)%d = drmer(i,j)*.001 ! Convert to km
+                valid = valid .and.  abs( (drmer(i,j)-gr%undef)   / gr%undef)   > 1e-4
+             else
+                data(k)%id = 'UICE'
+                data(k)%d = drzon(i,j)*.001 ! Convert to km
+                valid =  valid .and. abs( (drzon(i,j)-gr%undef)   / gr%undef)   > 1e-4
+             end if
+
+             if (.not.valid) then
+                data(k)%d = gr%undef
+             end if
+
+             data(k)%ipiv = i  ! Not really used for ice drift
+             data(k)%jpiv = j  ! Not really used for ice drift
+             data(k)%i_orig_grid = i ! Used for ice drift
+             data(k)%j_orig_grid = j ! Used for ice drift
+             data(k)%lat=drlat(i,j)
+             data(k)%lon=ang180(drlon(i,j))
+             !LB: Data support is assumed = a square grid cell
+             !support diameter in meters stored in %a1 (tricky, isn't it ?)
+             ! KAL -- hardcoded from data
+             data(k)%a1 = 1.4 * 16000.0
+             data(k)%ns = 1
+             ! To be decided - obs units are meters O(1e4)
+             ! CERSAT grid cells are of ~30 km - We assume the errors are
+             ! roughly ~15 km
+             !KAL data(k)%var = (15)**2
+             data(k)%var = var ! fom idrft.hdr specification
+             data(k)%depth = 0.0
+             data(k)%status = valid
+          enddo
+       enddo
+    enddo
+    print*, 'Number of data read:', k, gridpoints(gr)
+
+    print *,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+    print *,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+    print *,'!!!!!!!!! Adjust obs errors  !!!!!!!!!!!!!!!!!!!'
+    print *,'!!!!!!!Use qflag in valid as well!!!!!!!!!!!!!!!'
+    print *,'!!!!!!!!!!CHECK use of qflag !!!!!!!!!!!!!!!!!!!'
+    print *,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+    print *,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
+  end subroutine read_CERSAT_data
+
+
+  subroutine cersat_readfield(fname, ncid, varid, v, vlen)
+    use nfw_mod
+    implicit none
+
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    integer :: vlen
+    real(8), intent(out) :: v(vlen)
+    
+    real(8) :: scale_factor(1)
+    real(8) :: offset(1)
+
+    call nfw_get_att_double(fname, ncid, varid, 'scale_factor', scale_factor)
+    call nfw_get_att_double(fname, ncid, varid, 'add_offset', offset)
+    call nfw_get_var_double(fname, ncid, varid, v)
+    v = v * scale_factor(1) + offset(1)
+  end subroutine cersat_readfield
+
+end module m_read_CERSAT_data
+
+

EnKF-MPI-TOPAZ/Prep_Routines/m_read_CLS_SLA.F90

@@ -0,0 +1,133 @@
+module m_read_CLS_SLA
+! Reads CLS SLA data after having read the grid in read_CLS_SST_grid
+  contains
+
+  subroutine read_CLS_SLA(fname,gr,data)
+  use mod_measurement
+  use mod_grid
+  use m_spherdist
+  use netcdf
+  use m_nf90_err
+  implicit none
+
+  type (measurement),  intent(inout) :: data(:)
+  type (grid),         intent(inout) :: gr ! CLS measurement grid
+  character(len=80),   intent(in) :: fname
+
+!dimension ids
+  integer :: NbLatitudes_ID, NbLongitudes_ID, LatLon_ID
+
+! Variable ids
+  integer :: vNbLatitudes_ID, vNbLongitudes_ID, vGrid0001_ID
+
+! Array dimensions
+  integer :: LatLon, NbLatitudes, NbLongitudes
+
+! Data arrays
+  real,allocatable :: sla(:,:), lon(:),lat(:)
+
+! utilitary
+  integer ncid, ijmax(2)
+  real undef,undef_lat, undef_lon
+  integer i, j,k
+  logical valid
+  real, parameter :: eps = 0.01  ! test for undefined values
+
+! Open file
+!  filename='sst_topaz_19510.nc'
+  call nf90_err(NF90_OPEN(trim(fname),NF90_NOCLOBBER,ncid))
+  !call nfw_open(trim(fname), nf_nowrite, ncid)
+
+! Get dimension id in netcdf file ...
+  call nf90_err(nf90_Inq_Dimid(ncid,'LatLon',LatLon_ID))
+  call nf90_err(nf90_Inq_Dimid(ncid,'NbLatitudes',NbLatitudes_ID))
+  call nf90_err(nf90_Inq_Dimid(ncid,'NbLongitudes',NbLongitudes_ID))
+
+! Get dimension length from id
+  call nf90_err(nf90_Inquire_Dimension(ncid,LatLon_ID,len=LatLon))
+  call nf90_err(nf90_Inquire_Dimension(ncid,NbLatitudes_ID,len=NbLatitudes))
+  call nf90_err(nf90_Inquire_Dimension(ncid,NbLongitudes_ID,len=NbLongitudes))
+  print*, 'Dimensions:', NbLatitudes, NbLongitudes, LatLon
+
+! State which variable you want here.. Available vars are shown when you do
+! "ncdump -h " on the netcdf file. This is for SSH
+  allocate(lon(NbLongitudes))
+  allocate(lat(NbLatitudes))
+  allocate(sla(NbLatitudes,NbLongitudes))
+
+! Variable ids in netcdf file
+  call nf90_err(nf90_inq_varid(ncid,'NbLatitudes' ,vNbLatitudes_ID),'NbLatitudes')
+  call nf90_err(nf90_inq_varid(ncid,'NbLongitudes' ,vNbLongitudes_ID),'NbLongitudes')
+  call nf90_err(nf90_inq_varid(ncid,'Grid_0001' ,vGrid0001_ID),'Grid_0001')
+
+! Variable _FillValue attributes
+  call nf90_err(nf90_get_att(ncid,vNbLatitudes_ID , '_FillValue',undef_lat))
+  call nf90_err(nf90_get_att(ncid,vNbLongitudes_ID ,'_FillValue',undef_lon))
+  call nf90_err(nf90_get_att(ncid,vGrid0001_ID ,   '_FillValue',undef))
+  print*, 'Undefined values are ', undef_lat, undef_lon, undef
+  gr%undef = undef
+
+! actual variable values (for dimensions of var -- see ncdump, or improve this program)
+! NB: note that index dimensions are different between fortran and C internals. 
+! "ncdump" gives C internals.
+  print *,'test'
+  call nf90_err(nf90_get_var(ncid,vNbLongitudes_ID  ,lon))
+  !lon = ang180(lon)
+  print *,'Range Lon', minval(lon), maxval(lon)
+  call nf90_err(nf90_get_var(ncid,vNbLatitudes_ID   ,lat))
+  print *,'Range Lat', minval(lat), maxval(lat)
+  call nf90_err(nf90_get_var(ncid,vGrid0001_ID      ,sla))
+  print *,'Range SLA in cm ', minval(sla), maxval(sla)
+
+  print '(4a10)','Lat','Lon','SLA[cm]'
+  ijmax = minloc(sla)
+  do i=ijmax(1)-5, ijmax(1)+5
+    j = ijmax(2)
+    print '(4f10.3)', lat(i), lon(j), sla(i,j)
+  enddo
+
+  call nf90_err (nf90_close(ncid))
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Fill the data(:) vector
+
+  do j=1,NbLongitudes ! gr%ny
+  do i=1,NbLatitudes ! gr%nx
+     k=(j-1)*gr%nx+i
+
+     data(k)%id = 'SLA'
+     data(k)%d = sla(i,j) * 0.01  ! Conversion to meters
+
+     data(k)%ipiv = i
+     data(k)%jpiv = j
+
+     data(k)%lat=lat(i)
+     data(k)%lon=ang180(lon(j))
+
+!LB: Data support is assumed = a square grid cell
+!support diameter in meters stored in %a1 (tricky, isn't it ?)
+     data(k)%a1 = spherdist(lon(j)-.5*gr%dx,lat(i)-.5*gr%dy, &
+                            lon(j)+.5*gr%dx,lat(i)+.5*gr%dy)
+     data(k)%ns = 1
+ 
+     !data(k)%var = 0.01  ! 30cm temporarily, 10 cm by default
+     !PS
+     data(k)%var = 0.001  ! 30cm temporarily, 10 cm by default
+
+     data(k)%depth = 0.0
+
+     valid =   (abs( (lon(j)-undef_lon) / undef_lon ) > eps  & 
+         .and.  abs( (lat(i)-undef_lat) / undef_lat ) > eps  &
+         .and.  abs( (sla(i,j)-undef)   / undef )     > eps  )
+
+     data(k)%status = valid
+
+  enddo
+  enddo
+  print*, 'Number of data read:', k, gridpoints(gr)
+
+  deallocate(lat,lon,sla)
+   
+end subroutine read_CLS_SLA
+
+end module m_read_CLS_SLA

EnKF-MPI-TOPAZ/Prep_Routines/m_read_CLS_SSH.F90

@@ -0,0 +1,143 @@
+module m_read_CLS_SSH
+! Reads CLS SSH data after having read the grid in read_CLS_SST_grid
+  contains
+
+  subroutine read_CLS_SSH(fname,gr,data)
+  use mod_measurement
+!  use mod_dimensions
+  use mod_grid
+  use m_spherdist
+  use netcdf
+  use m_nf90_err
+  implicit none
+
+  type (measurement),  intent(inout) :: data(:)
+  type (grid),         intent(inout) :: gr ! CLS measurement grid
+  character(len=80),   intent(in) :: fname
+
+!dimension ids
+  integer :: NbLatitudes_ID, NbLongitudes_ID, LatLon_ID
+
+! Variable ids
+  integer :: vNbLatitudes_ID, vNbLongitudes_ID, vGrid0001_ID
+
+! Array dimensions
+  integer :: LatLon, NbLatitudes, NbLongitudes
+
+! Data arrays
+  real, allocatable :: ssh(:,:), lon(:),lat(:)
+
+! utilitary
+  integer ncid, ijmax(2)
+  real undef,undef_lat, undef_lon
+  integer i, j,k
+  logical valid
+  real, parameter :: eps = 0.01  ! test for undefined values
+
+! Open file
+!  filename='sst_topaz_19510.nc'
+  call nf90_err(NF90_OPEN(trim(fname),NF90_NOCLOBBER,ncid))
+
+! Get dimension id in netcdf file ...
+  call nf90_err(nf90_Inq_Dimid(ncid,'LatLon',LatLon_ID))
+  call nf90_err(nf90_Inq_Dimid(ncid,'NbLatitudes',NbLatitudes_ID))
+  call nf90_err(nf90_Inq_Dimid(ncid,'NbLongitudes',NbLongitudes_ID))
+  print*,'How far do you go'
+
+! Get dimension length from id
+  call nf90_err(nf90_Inquire_Dimension(ncid,LatLon_ID,len=LatLon))
+  call nf90_err(nf90_Inquire_Dimension(ncid,NbLatitudes_ID,len=NbLatitudes))
+  call nf90_err(nf90_Inquire_Dimension(ncid,NbLongitudes_ID,len=NbLongitudes))
+  print*, 'Dimensions:', NbLatitudes, NbLongitudes, LatLon
+
+! State which variable you want here.. Available vars are shown when you do
+! "ncdump -h " on the netcdf file. This is for SSH
+  allocate(lon(NbLongitudes))
+  allocate(lat(NbLatitudes))
+!  allocate(latlon0(LatLon))
+!  allocate(dlatlon(LatLon))
+  allocate(ssh(NbLatitudes,NbLongitudes))
+
+! Variable ids in netcdf file
+  call nf90_err(nf90_inq_varid(ncid,'NbLatitudes' ,vNbLatitudes_ID),'NbLatitudes')
+  call nf90_err(nf90_inq_varid(ncid,'NbLongitudes' ,vNbLongitudes_ID),'NbLongitudes')
+  call nf90_err(nf90_inq_varid(ncid,'Grid_0001' ,vGrid0001_ID),'Grid_0001')
+
+! Variable _FillValue attributes
+  call nf90_err(nf90_get_att(ncid,vNbLatitudes_ID , '_FillValue',undef_lat))
+  call nf90_err(nf90_get_att(ncid,vNbLongitudes_ID ,'_FillValue',undef_lon))
+  call nf90_err(nf90_get_att(ncid,vGrid0001_ID ,   '_FillValue',undef))
+  print*, 'Undefined values are ', undef_lat, undef_lon, undef
+  gr%undef = undef
+
+! actual variable values (for dimensions of var -- see ncdump, or improve this program)
+! NB: note that index dimensions are different between fortran and C internals. 
+! "ncdump" gives C internals.
+  print *,'test'
+  call nf90_err(nf90_get_var(ncid,vNbLongitudes_ID  ,lon))
+  !lon = ang180(lon)
+  print *,'Range Lon', minval(lon), maxval(lon)
+  call nf90_err(nf90_get_var(ncid,vNbLatitudes_ID   ,lat))
+  print *,'Range Lat', minval(lat), maxval(lat)
+  call nf90_err(nf90_get_var(ncid,vGrid0001_ID      ,ssh))
+  ssh = ssh - 130. ! LB Correction of offset in MDT
+  print *,'Range SSH in cm ', minval(ssh), maxval(ssh)
+
+!  print*, 'Latitudes'
+!  print '(12f8.2)',lat
+!  print*, 'Longitudes'
+!  print '(12f8.2)',lon
+  print '(4a10)','Lat','Lon','SSH[cm]'
+!   print*,lat,lon,temp(i),err_temp(i),saln(i),err_saln(i)
+!   write(13,*)lat,lon,saln(i),err_saln(i),depth(i)
+!   write(14,*)lat,lon,temp(i),err_temp(i),depth(i)
+  ijmax = minloc(ssh)
+  do i=ijmax(1)-5, ijmax(1)+5
+    j = ijmax(2)
+    print '(4f10.3)', lat(i), lon(j), ssh(i,j)
+  enddo
+
+  call nf90_err (nf90_close(ncid))
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Fill the data(:) vector
+
+  do j=1,NbLongitudes ! gr%ny
+  do i=1,NbLatitudes ! gr%nx
+     k=(j-1)*gr%nx+i
+
+     data(k)%id = 'SSH'
+     data(k)%d = ssh(i,j) * 0.01  ! Conversion to meters
+
+     data(k)%ipiv = i
+     data(k)%jpiv = j
+
+     data(k)%lat=lat(i)
+     data(k)%lon=ang180(lon(j))
+
+!LB: Data support is assumed = a square grid cell
+!support diameter in meters stored in %a1 (tricky, isn't it ?)
+     data(k)%a1 = spherdist(lon(j)-.5*gr%dx,lat(i)-.5*gr%dy, &
+                            lon(j)+.5*gr%dx,lat(i)+.5*gr%dy)
+     data(k)%ns = 1
+ 
+     data(k)%var = 0.05  ! 20cm temporarily, 10 cm by default
+     print*, 'SSH variance augmented: 22cm'
+
+     data(k) % depth = 0.0
+
+     valid =   (abs( (lon(j)-undef_lon) / undef_lon ) > eps  & 
+         .and.  abs( (lat(i)-undef_lat) / undef_lat ) > eps  &
+         .and.  abs( (ssh(i,j)-undef)   / undef )     > eps  )
+
+     data(k)%status = valid
+
+  enddo
+  enddo
+  print*, 'Number of data read:', k, gridpoints(gr)
+
+  deallocate(lat,lon,ssh)
+   
+end subroutine read_CLS_SSH
+
+end module m_read_CLS_SSH

EnKF-MPI-TOPAZ/Prep_Routines/m_read_CLS_SST.F90

@@ -0,0 +1,146 @@
+module m_read_CLS_SST
+! Reads CLS SST data after having read the grid in read_CLS_SST_grid
+  contains
+
+  subroutine read_CLS_SST(fname,gr,data)
+  use mod_measurement
+!  use mod_dimensions
+  use mod_grid
+  use m_spherdist
+  use netcdf
+  use m_nf90_err
+  implicit none
+
+  type (measurement),  intent(inout) :: data(:)
+  type (grid),         intent(inout) :: gr ! CLS measurement grid
+  character(len=80),   intent(in) :: fname
+
+!dimension ids
+  integer :: NbLatitudes_ID, NbLongitudes_ID, LatLon_ID
+
+! Variable ids
+  integer :: vNbLatitudes_ID, vNbLongitudes_ID, vGrid0001_ID, vGrid0004_ID
+
+! Array dimensions
+  integer :: LatLon, NbLatitudes, NbLongitudes
+
+! Data arrays
+  real,allocatable :: sst(:,:), sst_var(:,:), lon(:),lat(:)!, latlon0(:), dlatlon(:)
+
+! utilitary
+  integer ncid, ijmax(2)
+  real undef,undef_lat, undef_lon, undef_var
+  integer i, j,k
+  logical valid
+  real, parameter :: eps = 0.01  ! test for undefined values
+
+! Open file
+!  filename='sst_topaz_19510.nc'
+  call nf90_err(NF90_OPEN(trim(fname),NF90_NOCLOBBER,ncid))
+
+! Get dimension id in netcdf file ...
+  call nf90_err(nf90_Inq_Dimid(ncid,'LatLon',LatLon_ID))
+  call nf90_err(nf90_Inq_Dimid(ncid,'NbLatitudes',NbLatitudes_ID))
+  call nf90_err(nf90_Inq_Dimid(ncid,'NbLongitudes',NbLongitudes_ID))
+
+! Get dimension length from id
+  call nf90_err(nf90_Inquire_Dimension(ncid,LatLon_ID,len=LatLon))
+  call nf90_err(nf90_Inquire_Dimension(ncid,NbLatitudes_ID,len=NbLatitudes))
+  call nf90_err(nf90_Inquire_Dimension(ncid,NbLongitudes_ID,len=NbLongitudes))
+  print*, 'Dimensions:', NbLatitudes, NbLongitudes, LatLon
+
+! State which variable you want here.. Available vars are shown when you do
+! "ncdump -h " on the netcdf file. This is for SST and SDEV of SST
+  allocate(lon(NbLongitudes))
+  allocate(lat(NbLatitudes))
+!  allocate(latlon0(LatLon))
+!  allocate(dlatlon(LatLon))
+  allocate(sst_var(NbLatitudes,NbLongitudes))
+  allocate(sst(NbLatitudes,NbLongitudes))
+
+! Variable ids in netcdf file
+  call nf90_err(nf90_inq_varid(ncid,'NbLatitudes' ,vNbLatitudes_ID),'NbLatitudes')
+  call nf90_err(nf90_inq_varid(ncid,'NbLongitudes' ,vNbLongitudes_ID),'NbLongitudes')
+  call nf90_err(nf90_inq_varid(ncid,'Grid_0001' ,vGrid0001_ID),'Grid_0001')
+  call nf90_err(nf90_inq_varid(ncid,'Grid_0004' ,vGrid0004_ID),'Grid_0004')
+
+! Variable _FillValue attributes
+  call nf90_err(nf90_get_att(ncid,vNbLatitudes_ID , '_FillValue',undef_lat))
+  call nf90_err(nf90_get_att(ncid,vNbLongitudes_ID ,'_FillValue',undef_lon))
+  call nf90_err(nf90_get_att(ncid,vGrid0001_ID ,   '_FillValue',undef))
+  call nf90_err(nf90_get_att(ncid,vGrid0004_ID ,   '_FillValue',undef_var))
+  print*, 'Undefined values are ', undef_lat, undef_lon, undef, undef_var
+  gr%undef = undef
+
+! actual variable values (for dimensions of var -- see ncdump, or improve this program)
+! NB: note that index dimensions are different between fortran and C internals. 
+! "ncdump" gives C internals.
+  print *,'test'
+  call nf90_err(nf90_get_var(ncid,vNbLongitudes_ID  ,lon))
+  print *,'Range Lon', minval(lon), maxval(lon)
+  call nf90_err(nf90_get_var(ncid,vNbLatitudes_ID   ,lat))
+  print *,'Range Lat', minval(lat), maxval(lat)
+  call nf90_err(nf90_get_var(ncid,vGrid0001_ID      ,sst))
+  print *,'Range SST', minval(sst), maxval(sst)
+  call nf90_err(nf90_get_var(ncid,vGrid0004_ID      ,sst_var))
+  print *,'Range Std. Dev.', minval(sst_var), maxval(sst_var)
+
+!  print*, 'Latitudes'
+!  print '(12f8.2)',lat
+!  print*, 'Longitudes'
+!  print '(12f8.2)',lon
+  print '(4a10)','Lat','Lon','Temp[C]','Error[C]'
+!   print*,lat,lon,temp(i),err_temp(i),saln(i),err_saln(i)
+!   write(13,*)lat,lon,saln(i),err_saln(i),depth(i)
+!   write(14,*)lat,lon,temp(i),err_temp(i),depth(i)
+  ijmax = minloc(sst)
+  do i=ijmax(1)-5, ijmax(1)+5
+    j = ijmax(2)
+    print '(4f10.3)', lat(i), lon(j), sst(i,j), sst_var(i,j)
+  enddo
+
+  call nf90_err (nf90_close(ncid))
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Fill the data(:) vector
+
+  do j=1,NbLongitudes ! gr%ny
+  do i=1,NbLatitudes ! gr%nx
+     k=(j-1)*gr%nx+i
+
+     data(k)%id = 'SST'
+     data(k)%d = sst(i,j)
+
+     data(k)%ipiv = i
+     data(k)%jpiv = j
+
+     data(k)%lat=lat(i)
+     data(k)%lon=lon(j)
+
+!LB: Data support is assumed = a square grid cell
+!support diameter in meters stored in %a1 (tricky, isn't it ?)
+     data(k)%a1 = spherdist(lon(j)-.5*gr%dx,lat(i)-.5*gr%dy, &
+                            lon(j)+.5*gr%dx,lat(i)+.5*gr%dy)
+     data(k)%ns = 1
+ 
+     data(k)%var = sst_var(i,j)  ! corrected: variance is provided
+
+     data(k)%depth = 0.0
+
+     valid =   (abs( (lon(j)-undef_lon) / undef_lon ) > eps  & 
+         .and.  abs( (lat(i)-undef_lat) / undef_lat ) > eps  &
+         .and.  abs( (sst(i,j)-undef)   / undef )     > eps  &
+         .and.  abs( (sst_var(i,j)-undef_var)/undef_var) > eps &
+         .and.  sst_var(i,j)> 0 &
+         .and.  sst_var(i,j)< 16 )   ! Sdev too high => perturbations too large
+
+     data(k)%status = valid
+
+  enddo
+  enddo
+  print*, 'Number of data read:', k, gridpoints(gr)
+
+  deallocate(lat,lon,sst,sst_var)
+
+end subroutine read_CLS_SST
+end module m_read_CLS_SST

EnKF-MPI-TOPAZ/Prep_Routines/m_read_CLS_SST_grid.F90

@@ -0,0 +1,77 @@
+module m_read_CLS_SST_grid
+ ! Reads the CLS SST NetCDF dimensions
+
+contains
+subroutine read_CLS_SST_grid(filename,gr)
+  !use mod_dimensions
+  use mod_grid
+  use netcdf
+  use m_nf90_err
+  !use nfw_mod
+  implicit none
+
+  character(len=80), intent(in) :: filename
+  type(grid),        intent(out) :: gr
+
+!dimension ids
+  integer :: NbLatitudes_ID, NbLongitudes_ID, LatLon_ID
+
+
+! Array dimensions
+  integer :: LatLon, NbLatitudes, NbLongitudes
+  real, allocatable :: latlon0(:), dlatlon(:)
+
+!variables ids
+  integer :: vLatLonMin_ID, vLatLonStep_ID
+
+  integer :: ncid
+
+  gr = default_grid
+
+! Open file
+!filename='sst_topaz_19510.nc'
+  call nf90_err(NF90_OPEN(trim(filename),NF90_NOCLOBBER,ncid))
+  !call nfw_open(trim(filename), nf_nowrite, ncid)
+
+! Get dimension id in netcdf file ...
+  call nf90_err(nf90_Inq_Dimid(ncid,'LatLon',LatLon_ID))
+  call nf90_err(nf90_Inq_Dimid(ncid,'NbLatitudes',NbLatitudes_ID))
+  call nf90_err(nf90_Inq_Dimid(ncid,'NbLongitudes',NbLongitudes_ID))
+! Get dimension length from id
+  call nf90_err(nf90_Inquire_Dimension(ncid,LatLon_ID,len=LatLon))
+  call nf90_err(nf90_Inquire_Dimension(ncid,NbLatitudes_ID,len=NbLatitudes))
+  call nf90_err(nf90_Inquire_Dimension(ncid,NbLongitudes_ID,len=NbLongitudes))
+!  call nf90_err(nf90_Inquire_Dimension(ncid,GridDepth_ID,len=GridDepth))
+  print*, 'Dimensions:', NbLatitudes, NbLongitudes, LatLon
+
+  allocate(latlon0(LatLon))  ! Grid origin coordinates
+  allocate(dlatlon(LatLon))  ! dx and dy
+
+! Variable ids in netcdf file
+  call nf90_err(nf90_inq_varid(ncid,'LatLonMin' ,vLatLonMin_ID),'LatLonMin')
+  call nf90_err(nf90_inq_varid(ncid,'LatLonStep' ,vLatLonStep_ID),'LatLonStep')
+
+! Variables in NetCDF file
+  call nf90_err(nf90_get_var(ncid,vLatLonMin_ID     ,latlon0))
+  print *, 'Grid Origin ', latlon0
+  call nf90_err(nf90_get_var(ncid,vLatLonStep_ID    ,dlatlon))
+  print *, 'Grid Size ', dlatlon
+
+  gr%nx=NbLatitudes
+  gr%ny=NbLongitudes
+  gr%x0=   latlon0(1)
+  gr%y0=   latlon0(2)
+!  gr%dx=   0.179
+  gr%dx=   dlatlon(1)
+  gr%dy=   dlatlon(2)
+  gr%reg = .true.
+  gr%order = 2
+  gr%ux = 'deg'
+  gr%uy = 'deg'
+  gr%set = .true.
+
+  deallocate(latlon0,dlatlon)
+
+  end subroutine read_CLS_SST_grid
+end module m_read_CLS_SST_grid
+

EnKF-MPI-TOPAZ/Prep_Routines/m_read_CLS_TSLA.F90

@@ -0,0 +1,397 @@
+module m_read_CLS_TSLA
+
+  integer, parameter, private :: STRLEN = 512
+  real(8), parameter, private :: RE_MULTIPLE = 0.7d0
+  character(*), parameter, private :: RE_FNAME = "re_sla.nc"
+
+contains
+
+  subroutine read_CLS_TSLA(filename, gr, data)
+    use mod_measurement
+    use mod_grid
+    use nfw_mod
+    implicit none
+
+    character(*), intent(in) :: filename
+    type(grid), intent(inout) :: gr ! CLS measurement grid
+    type(measurement), intent(inout) :: data(:)
+
+    integer :: data_ID, track_ID, cycl_ID
+    integer :: vNbpoint_ID, vLongitude_ID, vLatitude_ID, vBegindate_ID, vSLA_ID
+
+    ! array dimensions
+    integer :: nb, ntracks, ncycles
+
+    ! data arrays
+    real(8), allocatable :: vsla(:,:), vlon(:), vlat(:), vbegindate(:,:)
+    integer, allocatable :: vnbpoint(:)
+    logical, allocatable :: isgood(:,:)
+
+    integer :: ncid
+    real(8), dimension(1) :: undef_sla, undef_lat, undef_lon, undef_begindate
+    real(8) :: varsat
+    integer, dimension(1) :: undef_nbpoint
+    integer :: i, j, k, nobs, obsid, sid, age
+    real(8), parameter :: EPS = 0.01  ! test for undefined values
+    character(STRLEN) :: ftemplate
+    character(STRLEN) :: fname
+    character(STRLEN) :: fpath
+    logical :: ex
+
+    print *, 'read_CLS_TSLA():'
+
+    fpath='./'
+    read(filename,'(i7)') age
+    nobs = 0
+    do sid = 1, 7 ! loop over satellite ID
+       select case(sid)
+       case(1)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_en*.nc'
+          varsat = 0.0009 ! 3 cm for ENVISAT 
+          print *, '  ENVISSAT:'
+       case(2)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_j1*.nc'
+          varsat = 0.0009 ! 3 cm for ENVISAT Jason1
+          print *, '  Jason1:'
+       case(3)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_j2*.nc'
+          varsat = 0.0009 ! 3 cm for ENVISAT Jason2
+          print *, '  Jason2:'
+       case(4)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_e1*.nc'
+          varsat = 0.0075 ! 8.5 cm for e1
+          print *, '  ERS1:'
+       case(5)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_e2*.nc'
+          varsat = 0.0075 ! 8.5 cm for e2
+          print *, '  ERS2:'
+       case(6)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_tp*.nc'
+          varsat = 0.0030 ! 5.5 cm for TOPEX 
+          print *, '  TOPEX:'
+       case(7)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_g2*.nc'
+          varsat = 0.0030 ! GEOSAT
+          print *, '  GEOSAT2:'
+       end select
+
+       call fname_fromtemplate(ftemplate, fname)
+       inquire(file = trim(fname), exist = ex)
+       if (.not. ex) then
+          cycle
+       end if
+
+       ! Reading the observation file of satellite
+       call nfw_open(fname, nf_nowrite, ncid)
+       call nfw_inq_dimid(fname, ncid, 'Data', data_ID)
+       call nfw_inq_dimid(fname, ncid, 'Tracks', track_ID)
+       call nfw_inq_dimid(fname, ncid, 'Cycles', cycl_ID)
+          
+       call nfw_inq_dimlen(fname, ncid, data_ID, nb)
+       call nfw_inq_dimlen(fname, ncid, track_ID, ntracks)
+       call nfw_inq_dimlen(fname, ncid, cycl_ID, ncycles)
+       print '(1x, a, 3i8)', '    dimensions (# obs, # tracks, # cycles):', nb, ntracks, ncycles
+       
+       allocate(vlon(nb), vlat(nb), vsla(ncycles, nb))
+       allocate(vnbpoint(ntracks), vbegindate(ncycles, ntracks))
+       allocate(isgood(ncycles, ntracks))
+          
+       ! Variable ids in netcdf file
+       call nfw_inq_varid(fname, ncid, 'Latitudes', vLatitude_ID)
+       call nfw_inq_varid(fname, ncid,'Longitudes', vLongitude_ID)
+       call nfw_inq_varid(fname, ncid,'BeginDates', vBegindate_ID)
+       call nfw_inq_varid(fname, ncid,'NbPoints', vNbpoint_ID)
+       call nfw_inq_varid(fname, ncid,'SLA', vSLA_ID)
+       
+       ! Variable _FillValue attributes
+       call nfw_get_att_double(fname, ncid, vLatitude_ID , '_FillValue', undef_lat(1))
+       call nfw_get_att_double(fname, ncid, vLongitude_ID , '_FillValue', undef_lon(1))
+       call nfw_get_att_double(fname, ncid, vSLA_ID, '_FillValue', undef_sla(1))
+       call nfw_get_att_int(fname, ncid, vNbpoint_ID, '_FillValue', undef_nbpoint(1))
+       call nfw_get_att_double(fname, ncid,vBegindate_ID, '_FillValue', undef_begindate(1))
+       gr % undef = undef_sla(1)
+          
+       call nfw_get_var_double(fname, ncid, vLongitude_ID, vlon)
+       call nfw_get_var_double(fname, ncid, vLatitude_ID, vlat)
+       call nfw_get_var_double(fname, ncid, vSLA_ID, vsla)
+       !lon = ang180(lon)
+       vlon = vlon * 1.e-06
+       vlat = vlat * 1.e-06
+       print '(1x, a, 2f10.2)', '    range Lon = ', minval(vlon), maxval(vlon)
+       print '(1x, a, 2f10.2)', '    range Lat = ', minval(vlat), maxval(vlat)
+       print '(1x, a, 2f10.2)', '    range SLA = ', minval(vsla), maxval(vsla)
+          
+       call nfw_get_var_int(fname, ncid, vNbpoint_ID, vnbpoint)
+       call nfw_get_var_double(fname, ncid, vBegindate_ID, vbegindate)
+       print '(1x, a, 2i8)', '    range nbpoints = ', minval(vnbpoint), maxval(vnbpoint)
+       print *, '    age = ', age
+       isgood = .false.
+       where (vbegindate /= undef_begindate(1))
+          vbegindate = age - floor(vbegindate) - 1
+          isgood = .true.
+       end where
+       print '(3x,a,2G10.3)','  range begin_date (days from assim) = ', &
+            minval(pack(vbegindate, isgood)), maxval(pack(vbegindate, isgood))
+       call nfw_close(fname, ncid)
+
+       ! Here we set the reference the date with respect to the assimilation
+       ! date (0=today, 6=is 6 day old).
+       ! Fanf: We assume that the data from the same pass have the same
+       ! date=begindate(passnb).
+       ! We also assume that envisat, J1 and J2 have similar accuracy, and 
+       ! thus use data%var to store the age of the data. Only data that are 
+       ! younger than 6 days are retained such that we do not assimilate the
+       ! same obs twice.
+       do k = 1, ncycles 
+          obsid = 0
+          do i = 1, ntracks
+             do j = 1, vnbpoint(i)
+                obsid = obsid + 1
+                ! only consider data above -30 of lat 
+                if (vlat(obsid) <= -30.0 .or.&
+                     vbegindate(k, i) >= 7 .or. vbegindate(k, i) <= -1 .or.&
+                     vlon(obsid) == undef_lon(1) .or.&
+                     vlat(obsid) == undef_lat(1) .or.&
+                     vsla(k, obsid) == undef_sla(1)) then
+                   cycle
+                end if
+                nobs = nobs + 1
+                data(nobs) % id = 'TSLA'
+                data(nobs) % d = vsla(k, obsid) * 0.001  ! conversion to meters
+                data(nobs) % ipiv = -1 ! to be filled
+                data(nobs) % jpiv = -1
+                data(nobs) % lat = vlat(obsid)
+                data(nobs) % lon = ang180(vlon(obsid))
+                data(nobs) % a1 = -1.0e10 ! to be filled
+                data(nobs) % a2 = -1.0e10
+                data(nobs) % a3 = -1.0e10
+                data(nobs) % a4 = -1.0e10
+                data(nobs) % ns = 0
+                data(nobs) % var = varsat
+                data(nobs) % date = int(vbegindate(k, i))
+                data(nobs) % depth = 0.0
+                data(nobs) % status = .true.
+             enddo   ! Vnbpoint
+          enddo    ! track
+       enddo   ! cycle
+       print*, '    # of obs read so far = ', nobs
+       deallocate(vlat, vlon, vsla, vnbpoint, vbegindate, isgood)
+    end do ! satellite id
+    gr % nx = nobs
+  end subroutine read_CLS_TSLA
+
+ subroutine read_MYO_TSLA(julday,dayinweek, gr, data)
+    use mod_measurement
+    use mod_grid
+    use nfw_mod
+    implicit none
+!Fanf: this routine assume that you have one seperate file for each day.
+!Call prepobs 7 times (for each cycle days with the date and the corrsponding
+!day in the cycle
+
+!    character(*), intent(in) :: filename
+    character(*), intent(in) :: julday, dayinweek
+    type(grid), intent(inout) :: gr ! MYO measurement grid
+    type(measurement), intent(inout) :: data(:)
+
+    integer :: time_ID !data_ID, track_ID, cycl_ID
+    integer :: vNbpoint_ID, vLongitude_ID, vLatitude_ID, vBegindate_ID, vSLA_ID, vtime_ID
+
+    ! array dimensions
+    integer :: nb !, ntracks, ncycles
+
+    ! data arrays
+    real(8), allocatable :: vsla(:), vlon(:), vlat(:), vtime(:)!, vbegindate(:,:)
+    logical, allocatable :: isgood(:)
+
+    integer :: ncid
+    real(8), dimension(1) :: undef_sla, undef_lat, undef_lon, undef_begindate, undef_time
+    real(8) :: varsat
+    integer, dimension(1) :: undef_nbpoint
+    integer :: i, j, k, nobs, obsid, sid, age, idayinweek
+    real(8), parameter :: EPS = 0.01  ! test for undefined values
+    character(STRLEN) :: ftemplate
+    character(STRLEN) :: fname
+    character(STRLEN) :: fpath
+    logical :: ex
+
+    print *, 'read_MYO_TSLA():'
+
+    fpath='./'
+    read(julday,'(i7)') age
+    read(dayinweek,'(i2)') idayinweek 
+    nobs = 0
+    do sid = 1, 9 ! loop over satellite ID
+       select case(sid)
+       case(1)
+          ftemplate = trim(fpath)//'sla_'//trim(julday)//'_en*.nc'
+          varsat = 0.0009 ! 3 cm for ENVISAT 
+          print *, '  ENVISSAT:'
+       case(2)
+          ftemplate = trim(fpath)//'sla_'//trim(julday)//'_j1*.nc'
+          varsat = 0.0009 ! 3 cm for ENVISAT Jason1
+          print *, '  Jason1:'
+       case(3)
+          ftemplate = trim(fpath)//'sla_'//trim(julday)//'_j2*.nc'
+          varsat = 0.0009 ! 3 cm for ENVISAT Jason2
+          print *, '  Jason2:'
+       case(4)
+          ftemplate = trim(fpath)//'sla_'//trim(julday)//'_e1*.nc'
+          varsat = 0.0075 ! 8.5 cm for e1
+          print *, '  ERS1:'
+       case(5)
+          ftemplate = trim(fpath)//'sla_'//trim(julday)//'_e2*.nc'
+          varsat = 0.0075 ! 8.5 cm for e2
+          print *, '  ERS2:'
+       case(6)
+          ftemplate = trim(fpath)//'sla_'//trim(julday)//'_tp*.nc'
+          varsat = 0.0030 ! 5.5 cm for TOPEX 
+          print *, '  TOPEX:'
+       case(7)
+          ftemplate = trim(fpath)//'sla_'//trim(julday)//'_g2*.nc'
+          varsat = 0.0030 ! GEOSAT
+          print *, '  GEOSAT2:'
+       case(8)
+          ftemplate = trim(fpath)//'sla_'//trim(julday)//'_c2*.nc'
+          varsat = 0.0030 ! CRYOSAT-2
+          print *, '  CRYOSAT2:'
+       case(9)
+          ftemplate = trim(fpath)//'sla_'//trim(julday)//'_al*.nc'
+          varsat = 0.0009 ! ALTIKA
+          print *, '  ALTIKA:'
+       end select
+
+       call fname_fromtemplate(ftemplate, fname)
+       inquire(file = trim(fname), exist = ex)
+       if (.not. ex) then
+          cycle
+       end if
+
+       ! Reading the observation file of satellite
+       call nfw_open(fname, nf_nowrite, ncid)
+       call nfw_inq_dimid(fname, ncid, 'time', time_ID)
+          
+       call nfw_inq_dimlen(fname, ncid, time_ID, nb)
+       print '(1x, a, i8)', '    dimensions (# obs):', nb !, ntracks, ncycles
+       
+       allocate(vlon(nb), vlat(nb), vsla(nb), vtime(nb))
+       allocate(isgood(nb))
+          
+       ! Variable ids in netcdf file
+       call nfw_inq_varid(fname, ncid, 'latitude', vLatitude_ID)
+       call nfw_inq_varid(fname, ncid,'longitude', vLongitude_ID)
+       call nfw_inq_varid(fname, ncid, 'time', vtime_ID)
+       call nfw_inq_varid(fname, ncid,'SLA', vSLA_ID)
+       
+       ! Variable _FillValue attributes
+       call nfw_get_att_double(fname, ncid, vSLA_ID, '_FillValue', undef_sla(1))
+       gr % undef = undef_sla(1)
+          
+       call nfw_get_var_double(fname, ncid, vLongitude_ID, vlon)
+       call nfw_get_var_double(fname, ncid, vLatitude_ID, vlat)
+       call nfw_get_var_double(fname, ncid, vSLA_ID, vsla)
+       call nfw_get_var_double(fname, ncid, vtime_ID, vtime)
+       !lon = ang180(lon)
+       vlon = vlon * 1.e-06
+       vlat = vlat * 1.e-06
+       print '(1x, a, 2f10.2)', '    range Lon = ', minval(vlon), maxval(vlon)
+       print '(1x, a, 2f10.2)', '    range Lat = ', minval(vlat), maxval(vlat)
+       print '(1x, a, 2f10.2)', '    range SLA = ', minval(vsla), maxval(vsla)
+          
+       print *, '    age = ', age
+       print '(3x,a,G10.3)','  Days before assim = ', idayinweek
+       call nfw_close(fname, ncid)
+
+       ! Here we set the reference the date with respect to the assimilation
+       ! date (0=today, 6=is 6 day old).
+       ! Fanf: We assume that the data from the same pass have the same
+       ! date=begindate(passnb).
+       ! We also assume that envisat, J1 and J2 have similar accuracy, and 
+       ! thus use data%var to store the age of the data. Only data that are 
+       ! younger than 6 days are retained such that we do not assimilate the
+       ! same obs twice.
+       obsid = 0
+       do k = 1, nb 
+          obsid = obsid + 1
+          ! only consider data above -30 of lat 
+          if (vlat(obsid) <= -30.0 .or.&
+               vsla(obsid) == undef_sla(1)) then
+             cycle
+          end if
+          nobs = nobs + 1
+          data(nobs) % id = 'TSLA'
+          data(nobs) % d = vsla(obsid) * 0.001  ! conversion to meters
+          data(nobs) % ipiv = -1 ! to be filled
+          data(nobs) % jpiv = -1
+          data(nobs) % lat = vlat(obsid)
+          data(nobs) % lon = ang180(vlon(obsid))
+          data(nobs) % a1 = -1.0e10 ! to be filled
+          data(nobs) % a2 = -1.0e10
+          data(nobs) % a3 = -1.0e10
+          data(nobs) % a4 = -1.0e10
+          data(nobs) % ns = 0
+          data(nobs) % var = varsat
+          data(nobs) % date = idayinweek
+          data(nobs) % depth = 0.0
+          data(nobs) % status = .true.
+       enddo   ! cycle
+       print*, '    # of obs read so far = ', nobs, obsid
+       deallocate(vlat, vlon, vsla, vtime, isgood)
+    end do ! satellite id
+    gr % nx = nobs
+  end subroutine read_MYO_TSLA
+
+  subroutine set_re_TSLA(nrobs, obs, nx, ny, modlon, modlat)
+    use mod_measurement
+    use nfw_mod
+
+    integer, intent(in) :: nrobs
+    type(measurement), dimension(nrobs), intent(inout) :: obs
+    integer, intent(in) :: nx, ny
+    real, dimension(nx, ny), intent(in)  ::  modlon, modlat
+
+    integer :: ncid, reid
+    real, dimension(nx, ny) :: re
+    real :: reo
+    integer :: o
+
+    print *, '  reading representation error from "', trim(RE_FNAME), '"'
+
+    call nfw_open(RE_FNAME, nf_nowrite, ncid)
+    call nfw_inq_varid(RE_FNAME, ncid, 're_sla', reid)
+    call nfw_get_var_double(RE_FNAME, ncid, reid, re)
+    call nfw_close(RE_FNAME, ncid)
+    
+    do o = 1, nrobs
+       reo = re(obs(o) % ipiv, obs(o) % jpiv)
+       if (reo < 0 .or. reo > 1.0d5) then
+          cycle
+       end if
+       ! PS 1.4.2010 Increased the multiple for representation error from
+       ! 0.3 to 0.5 - it seems that with 0.3 it wants to do more in the Gulf
+       ! Stream region than the model can sustain.
+       ! PS June 2010 - further increased the multiple to 0.7.
+       obs(o) % var = obs(o) % var + RE_MULTIPLE * reo
+    end do
+  end subroutine set_re_TSLA
+
+
+  subroutine fname_fromtemplate(ftemplate, fname)
+    character(*), intent(in) :: ftemplate
+    character(*), intent(inout) :: fname
+
+    character(STRLEN) :: command ! (there may be a limit of 80 on some systems)
+    integer :: ios
+
+    command = 'ls '//trim(ftemplate)//' 2> /dev/null > tsla_files.txt'
+    call system(trim(command));
+
+    open(10, file = 'tsla_files.txt')
+    read(10, fmt = '(a)', iostat = ios) fname
+    close(10)
+    if (ios /= 0) then
+       fname = ""
+    end if
+  end subroutine fname_fromtemplate
+
+end module m_read_CLS_TSLA

EnKF-MPI-TOPAZ/Prep_Routines/m_read_CLS_TSLA_grid.F90

@@ -0,0 +1,174 @@
+module m_read_CLS_TSLA_grid
+  ! Reads the CLS SST NetCDF dimensions
+
+  integer, parameter, private :: STRLEN = 512
+
+contains
+  subroutine read_CLS_TSLA_grid(filename,gr)
+    !use mod_dimensions
+    use mod_grid
+    use netcdf
+    use nfw_mod
+    implicit none
+
+    character(len=80), intent(in) :: filename
+    type(grid),        intent(out) :: gr
+    character(len=80) :: fname
+    logical :: ex
+    !dimension ids
+    integer :: data_ID,cycl_ID
+
+    ! Array dimensions
+    integer :: nb,cycl
+
+    integer :: ncid,fcount
+    character(STRLEN) :: Fpath
+    character(STRLEN) :: ftemplate
+
+    print *, 'read_CLS_TSLA_grid():'
+
+    gr = default_grid
+    gr%nx=0
+    Fpath='./'
+    ! Open file
+    do fcount=1,7 !2 satellite Envissat,J2
+       select case(fcount)
+       case(1)
+          ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_en*.nc'
+       case(2)  
+          ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_j1*.nc'
+       case(3)
+          ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_j2*.nc'
+       case(4)  
+          ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_e1*.nc'
+       case(5)  
+          ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_e2*.nc'
+       case(6)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_tp*.nc'
+       case(7)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_g2*.nc'
+       end select
+       call fname_fromtemplate(ftemplate, fname)
+       inquire(file=trim(fname),exist=ex)
+       if(ex) then
+          call nfw_open(fname, nf_nowrite, ncid)
+          print *, '  found "', trim(fname), '"...'
+
+          ! Get dimension id in netcdf file ...
+          call nfw_inq_dimid(fname, ncid, 'Data', data_ID)
+          call nfw_inq_dimid(fname, ncid, 'Cycles', cycl_ID)
+          ! Get dimension length from id
+          call nfw_inq_dimlen(fname, ncid, data_ID, nb)
+          call nfw_inq_dimlen(fname, ncid, cycl_ID, cycl)
+          call nfw_close(fname, ncid)
+
+          gr%nx=gr%nx+nb*cycl
+          gr%ny=1
+          gr%x0=0
+          gr%y0=0
+          gr%dx=0.1
+          gr%dy=0.1
+          gr%reg = .false.
+          gr%order = 1
+          gr%ux = 'm'
+          gr%uy = 'm'
+          gr%set = .true.
+       endif
+    enddo
+  end subroutine read_CLS_TSLA_grid
+  subroutine read_MYO_TSLA_grid(filename,gr)
+    !use mod_dimensions
+    use mod_grid
+    use netcdf
+    use nfw_mod
+    implicit none
+
+    character(len=80), intent(in) :: filename
+    type(grid),        intent(out) :: gr
+    character(len=80) :: fname
+    logical :: ex
+    !dimension ids
+    integer :: time_ID
+
+    ! Array dimensions
+    integer :: nb
+
+    integer :: ncid,fcount
+    character(STRLEN) :: Fpath
+    character(STRLEN) :: ftemplate
+
+    print *, 'read_MYO_TSLA_grid():'
+
+    gr = default_grid
+    gr%nx=0
+    Fpath='./'
+    ! Open file
+    do fcount=1,9 !2 satellite Envissat,J2
+       select case(fcount)
+       case(1)
+          ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_en*.nc'
+       case(2)  
+          ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_j1*.nc'
+       case(3)
+          ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_j2*.nc'
+       case(4)  
+          ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_e1*.nc'
+       case(5)  
+          ftemplate=trim(Fpath)//'sla_'//trim(filename)//'_e2*.nc'
+       case(6)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_tp*.nc'
+       case(7)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_g2*.nc'
+       case(8)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_c2*.nc'
+       case(9)
+          ftemplate = trim(fpath)//'sla_'//trim(filename)//'_al*.nc'
+       end select
+       call fname_fromtemplate(ftemplate, fname)
+       inquire(file=trim(fname),exist=ex)
+       if(ex) then
+          call nfw_open(fname, nf_nowrite, ncid)
+          print *, '  found "', trim(fname), '"...'
+
+          ! Get dimension id in netcdf file ...
+          call nfw_inq_dimid(fname, ncid, 'time', time_ID)
+          ! Get dimension length from id
+          call nfw_inq_dimlen(fname, ncid, time_ID, nb)
+          call nfw_close(fname, ncid)
+
+          gr%nx=gr%nx+nb
+          gr%ny=1
+          gr%x0=0
+          gr%y0=0
+          gr%dx=0.1
+          gr%dy=0.1
+          gr%reg = .false.
+          gr%order = 1
+          gr%ux = 'm'
+          gr%uy = 'm'
+          gr%set = .true.
+       endif
+    enddo
+  end subroutine read_MYO_TSLA_grid
+  
+  
+
+  subroutine fname_fromtemplate(ftemplate, fname)
+    character(*), intent(in) :: ftemplate
+    character(*), intent(inout) :: fname
+
+    character(STRLEN) :: command ! (there may be a limit of 80 on some systems)
+    integer :: ios
+
+    command = 'ls '//trim(ftemplate)//' 2> /dev/null > tsla_files.txt'
+    call system(trim(command));
+
+    open(10, file = 'tsla_files.txt')
+    read(10, fmt = '(a)', iostat = ios) fname
+    close(10)
+    if (ios /= 0) then
+       fname = ""
+    end if
+  end subroutine fname_fromtemplate
+
+end module m_read_CLS_TSLA_grid

EnKF-MPI-TOPAZ/Prep_Routines/m_read_CLS_data.F90

@@ -0,0 +1,117 @@
+ module m_read_CLS_data
+! Reads SLA and SST data from CLS, Toulouse, France
+! Files are given as .asc (lat,lon,data) 
+! The data points are surface data and therefore the data(k)%depths=0
+! This subroutine also prepares the gridd which the data
+! Is provided on.
+
+contains
+
+  subroutine read_CLS_data(fname,obstype,dformat,gr,form,data,factor,var)
+  use mod_measurement
+  use mod_grid
+  use m_spherdist
+  implicit none
+
+  type (measurement), intent(inout)  :: data(:)
+  type (grid), intent(in)           :: gr ! CLS measurement grid
+  real, intent(in) :: factor, var
+
+  character(len=80), intent(in) :: fname,dformat
+  character(len=3), intent(in)::form
+  character(len=*), intent(in)::obstype
+  integer :: k, telli, tellj, nrdat, dum
+  logical :: ex, found, fleeting
+  real :: lon, lat
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Read  observation file
+  if (trim(form) == '0') stop 'read_CLS_data: illegal format '
+  inquire (file=fname, exist=ex)
+  if (.not. ex) then
+     print *, 'read_CLS_data: file ', fname, ' not found.'
+     stop
+  end if
+
+!std = 0.0; lat = 0.0; lon = 0.0
+
+!!! Find out if data column is type integer or not
+
+  found = .false.
+  found = ((scan(dformat,'i') > 0) .or. (scan(dformat,'I') > 0))
+  fleeting = .not. found
+ 
+  open (10, file=fname, form='formatted', status='old')
+
+  telli=1  
+  tellj=1
+
+  do k = 1, gridpoints(gr) 
+     data(k)%id = obstype
+
+     if (fleeting) then  ! Data column floating point
+       read (10,dformat,end=999,err=999) lat, lon, data(k)%d
+     else  ! Data column integer valued
+       read (10,dformat,end=999,err=999) lat, lon, dum
+       data(k)%d = real(dum)
+     end if
+!      print*,'lat',lat,'lon', lon,'data',data(k)%d
+
+!NBNBN Avoid sla data in region 3S to 3N (due to strange Ifremer mean ssh in this region):
+
+!     if (trim(data(k)%id) == 'ssh' .or. trim(data(k)%id) == 'SSH') then
+!        if ((lat.ge.-3.0).and.(lat.le.3.0)) then
+!           data(k)%d = 999.9
+!        endif
+!     endif
+
+     if (.not. undefined(data(k)%d,gr)) then
+         data(k)%d = data(k)%d*factor ! Convert to proper units
+     end if
+
+     data(k)%jpiv = telli
+     data(k)%ipiv = tellj
+!        iloop(k) = telli
+!        jloop(k) = tellj
+        
+
+     telli = telli + 1
+
+     if (telli > gr%ny) then
+        tellj=tellj+1
+        telli = 1
+     endif
+
+     data(k)%lon=lon
+     data(k)%lat=lat
+
+!LB: Data support is assumed = a square grid cell
+!support diameter stored in %a1 (tricky, isn't it ?)
+     data(k)%a1 = spherdist(lon-.5*gr%dx,lat-.5*gr%dy,lon+.5*gr%dx,lat+.5*gr%dy)
+     data(k)%ns = 1
+     data(k)%status = .not. undefined(data(k)%d,gr) ! active data
+
+     if (trim(obstype) == 'SST') then
+        data(k) % status = data(k) % status .and.&
+             abs(data(k) % d + 1.8d0) > 1.0d-6
+     end if
+ 
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! In the case of SSH data the var parameter is given for each data point !!!!
+!
+     if (trim(data(k)%id) == 'ssh' .or. trim(data(k)%id) == 'SSH') then
+       data(k)%var = var !!!NBNBNB + std**2 
+     else 
+       data(k)%var = var
+     endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+     data(k)%depth = 0.0
+  enddo ! k = 1, gridpoints(gr)
+999 continue
+  nrdat =k-1
+  print*, 'Number of data read:', nrdat
+  close(10)
+
+end subroutine read_CLS_data
+
+end module m_read_CLS_data

EnKF-MPI-TOPAZ/Prep_Routines/m_read_CLS_header.F90

@@ -0,0 +1,66 @@
+ module m_read_CLS_header
+! Reads the CLS header stored as sla.hdr or sst.hdr
+
+contains
+  subroutine read_CLS_header(fnamehdr,gr,dataformat,form,factor,var)
+  use mod_grid
+  implicit none
+
+  type (grid), intent(out)       :: gr
+
+  character(len=80),intent(in) :: fnamehdr
+  character(len=80),intent(out) :: dataformat
+  character(len=80) :: title
+  character(len=3), intent (out)::form
+  integer :: lastchar
+  real, intent(out) :: factor, var
+
+  logical :: ex
+
+  gr = default_grid
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Read .hdr file information
+   inquire (file=fnamehdr,exist=ex)
+   if (ex) then
+     open (10,file=fnamehdr)
+     read (10,'(a)') title
+     read (10,'(a3)') form
+     read (10,'(a80)') dataformat
+     read (10,*) gr%undef, factor, var
+     lastchar = scan(dataformat,')')
+     dataformat(lastchar+1:80) = ' '
+     print '(2a)','title      : ', trim(title)
+     print '(2a)','Form       : ', form
+     print '(2a)','data format: ', trim(dataformat)
+     print '(a,3e14.3)','undef factor var: ', gr%undef,factor,var
+
+!Reads the observation gridd
+      if (form == 'reg') then
+         read (10,*) gr%nx,gr%ny,gr%x0,gr%y0,gr%dx,gr%dy
+         gr%reg = .true.
+         gr%order = 2
+         gr%ux = 'deg'
+         gr%uy = 'deg'
+      elseif (form == 'irr') then
+         read (10,*) gr%nx
+         gr%reg = .false.
+         gr%order = 1
+      else
+         stop 'readhdr: Header error, format should be reg or irr'
+      end if
+   gr%set = .true.
+   close (10)
+
+   else
+      form = '0' ! File not found.
+      gr%set = .false.
+      print*, title
+      stop 'read_CLS_header: no data header'
+   end if
+
+      print *,' No of gridpoints: ', gridpoints(gr)
+!      print '(a,a3,a,f8.4)','Error variance of dataset ',obstype, ' is', var
+end subroutine read_CLS_header
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+end module m_read_CLS_header

EnKF-MPI-TOPAZ/Prep_Routines/m_read_FFI_glider.F90

@@ -0,0 +1,202 @@
+! File:          m_read_FFI_glider.F90
+!
+! Created:       November 2009
+!
+! Author:        Pavel Sakov
+!                NERSC
+!
+! Purpose:       Read glider data from text files by FFI into TOPAZ system
+!
+! Description:   Data file(s) are defined by the string in the 4th line of
+!                "infile.data". It should have the following format:
+!                <BEGIN>
+!                FFI
+!                GSAL | GTEM
+!                <obs. error variance>
+!                <File name>
+!                <END>
+!
+!                This is a very beta code, just to make an initial assessment.
+!
+! Modifications: none
+
+module m_read_FFI_glider
+  implicit none
+
+  integer, parameter, private :: STRLEN = 512
+
+  public read_ffi_glider
+
+  private grid_readxyz
+
+contains
+
+  subroutine read_ffi_glider(fname, obstype, variance, nx, ny, data)
+    use mod_measurement
+    use m_confmap
+    use m_oldtonew
+    use m_pivotp
+    use m_bilincoeff
+
+    character(*), intent(in) :: fname
+    character(*), intent(in) :: obstype
+    real, intent(in) :: variance
+    integer, intent(in) :: nx, ny
+    type(measurement), allocatable, intent(out) :: data(:)
+
+    real, dimension(nx, ny) :: modlat, modlon, depths
+    real :: latnew, lonnew
+
+    character(STRLEN) :: record
+    integer :: ios
+    integer :: r, nr, o, nobs, oo
+
+    real :: tmp
+    type(measurement) :: obs
+    type(measurement), allocatable :: tmpdata(:)
+
+    ! count number of records
+    !
+    open(10, file = trim(fname), access = 'sequential', status = 'old', iostat = ios)
+    if (ios /= 0) then
+       print *, 'ERROR: read_FFI_glider(): could not open "', fname, '"'
+    end if
+    nr = 1
+    do while(.true.)
+       read(10, *, iostat = ios) record
+       if (ios /= 0) then
+          exit
+       end if
+       nr = nr + 1
+    end do
+
+    print *, trim(fname), ': ', nr, ' lines'
+    if (nr == 0) then
+       print *, 'ERROR: read_FFI_glider(): "', fname, '": empty file?'
+       stop
+    end if
+
+    allocate(data(nr))
+
+    close(10)
+    open(10, file = trim(fname), access = 'sequential', status = 'old')
+    nobs = 0
+    do r = 1, nr
+       if (trim(obstype) == 'GSAL' .or. trim(obstype) == 'SAL') then
+          read(10, *, iostat = ios) obs % date, obs % lat, obs % lon, obs % depth, tmp, tmp, obs % d
+       elseif (trim(obstype) == 'GTEM' .or. trim(obstype) == 'TEM') then
+          read(10, *, iostat = ios) obs % date, obs % lat, obs % lon, obs % depth, tmp, obs % d, tmp
+       else
+          print *, trim(fname), ': unknown data type "', trim(obstype), '"'
+          stop
+       end if
+       if (obs % date <= 0) then
+          cycle
+       end if
+       nobs = nobs + 1
+       data(nobs) = obs
+    end do
+    close(10)
+
+    allocate(tmpdata(1 : nobs))
+    tmpdata = data(1 : nobs)
+    deallocate(data)
+    allocate(data(nobs))
+    data = tmpdata
+    deallocate(tmpdata)
+
+    if (nobs == 0) then
+       print *, 'ERROR: read_FFI_glider(): "', trim(fname),&
+            '": no meaningful data for ', trim(obstype), ' found'
+       stop
+    end if
+    print *, trim(fname), ': ', nobs, ' records for ', trim(obstype)
+
+    data % id = obstype
+    data % var = variance
+    data % status = .true.
+    data % ns = 0
+    data % i_orig_grid = 0
+    ! convert seconds since 1/1/1970 to days since 1/1/1950
+    !
+    ! data(1 : nobs) % date = data(1 : nobs) % date / 86400 + 7305
+
+    call confmap_init(nx, ny)
+    call grid_readxyz(nx, ny, modlat, modlon, depths)
+    do o = 1, nobs
+       call oldtonew(data(o) % lat, data(o) % lon, latnew, lonnew)
+       call pivotp(lonnew, latnew, data(o) % ipiv, data(o) % jpiv)
+       if (data(o) % ipiv < 1 .or. data(o) % jpiv < 1&
+            .or. data(o) % ipiv > nx - 1 .or. data(o) % jpiv > ny - 1) then
+          data(o) % status = .false.
+       else
+          call bilincoeff(modlon, modlat, nx, ny, data(o) % lon, data(o) % lat,&
+               data(o) % ipiv, data(o) % jpiv, data(o) % a1, data(o) % a2,&
+               data(o) % a3, data(o) % a4)
+       end if
+    end do
+
+    ! some basic QC
+    where (data % depth < 0.0d0 .or. data % depth > 6000.0d0)
+       data % status = .false.
+    end where
+    if (trim(obstype) == 'TEM') then
+       where (data % d < -3.0d0 .or. data % d > 40.0d0)
+          data % status = .false.
+       end where
+    elseif (trim(obstype) == 'SAL') then
+       where (data % d < 30.0d0 .or. data % d > 40.0d0)
+          data % status = .false.
+       end where
+    end if
+
+    allocate(tmpdata(1 : count(data % status)))
+    oo = 0
+    do o = 1, nobs
+       if (data(o) % status) then
+          oo = oo + 1
+          tmpdata(oo) = data(o)
+       end if
+    end do
+    nobs = oo
+    deallocate(data)
+    allocate(data(nobs))
+    data = tmpdata
+    deallocate(tmpdata)
+
+  end subroutine read_ffi_glider
+
+
+  ! Copied from m_read_ifremer_argo.
+  !
+  subroutine grid_readxyz(nx, ny, lat, lon, depth)
+    integer, intent(in) :: nx, ny
+    real(8), dimension(nx, ny), intent(inout) :: lat, lon, depth
+
+    logical :: exists
+    character(len = 128) :: fname
+    
+    fname = 'newpos.uf'
+    inquire(file = fname, exist = exists)
+    if (.not. exists) then
+       print *, 'grid_readxyz(): ERROR: "', trim(fname), '" does not exist'
+       stop
+    end if
+    open(10, file = fname, form = 'unformatted', status = 'old')
+    print *, '  grid_readxyz(): reading "', trim(fname), '"...'
+    read(10) lat, lon
+    close(10)
+
+    write(fname, '(a, i3.3, a, i3.3, a)') 'depths', nx, 'x', ny, '.uf'
+    inquire(file = fname, exist = exists)
+    if (.not. exists) then
+       print*, 'grid_readxyz(): ERROR: "', trim(fname), '" does not exist'
+       stop
+    end if
+    open (unit = 10, file = fname, status = 'old', form = 'unformatted')
+    print *, '  grid_readxyz(): reading "', trim(fname), '"...'
+    read(10) depth
+    close(10)
+  end subroutine grid_readxyz
+
+end module m_read_FFI_glider

EnKF-MPI-TOPAZ/Prep_Routines/m_read_MET_SST.F90

@@ -0,0 +1,100 @@
+module m_read_MET_SST
+  ! Reads CLS SLA data after having read the grid in read_CLS_SST_grid
+
+  integer, parameter, private :: STRLEN = 512
+
+contains
+
+  subroutine read_MET_SST(filename,gr,data)
+    use mod_measurement
+    use mod_grid
+    use m_spherdist
+    use netcdf
+    use nfw_mod
+    implicit none
+
+    type (measurement),  intent(inout) :: data(:)
+    type (grid),         intent(inout) :: gr ! CLS measurement grid
+    character(len=80),   intent(in) :: filename
+
+    ! Variable ids
+    integer :: lon_ID, lat_ID,vsst_ID, vstd_ID, vmask_ID
+    ! Data arrays
+    real, allocatable :: sst(:,:), lon(:), lat(:), std(:,:)
+    integer, allocatable :: mask(:,:)
+    integer :: ncid ! observations
+    real, dimension(1) :: undef_sst
+    integer :: i, j, count1
+    real, parameter :: eps = 0.01  ! test for undefined values
+    ! filen name
+    logical         :: ex
+
+    print *, 'read_MET_SST:'
+
+    inquire(file=trim(filename),exist=ex)
+    if (ex) then
+       ! Reading the observation file 
+       call nfw_open(filename, nf_nowrite, ncid)
+       ! Get dimension id in netcdf file ...
+       !nb total of data
+       allocate(lon(gr%nx), lat(gr%ny), sst(gr%nx,gr%ny), std(gr%nx, gr%ny), mask(gr%nx, gr%ny))
+
+       ! Variable ids in netcdf file
+       call nfw_inq_varid(filename, ncid, 'lat', lat_ID)
+       call nfw_inq_varid(filename, ncid,'lon', lon_ID)
+       call nfw_inq_varid(filename, ncid,'analysed_sst' ,vsst_ID)
+       call nfw_inq_varid(filename, ncid,'analysis_error' ,vstd_ID)
+       call nfw_inq_varid(filename, ncid,'mask' ,vmask_ID)
+       
+       ! Variable _FillValue attributes
+       call nfw_get_att_double(filename, ncid, vsst_ID, '_FillValue', undef_sst(1))
+       gr % undef = undef_sst(1)
+       
+       ! actual variable values (for dimensions of var -- see ncdump, or improve this program)
+       ! NB: note that index dimensions are different between fortran and C internals. 
+       ! "ncdump" gives C internals.
+       call nfw_get_var_double(filename, ncid, lon_ID, lon)
+       call nfw_get_var_double(filename, ncid, lat_ID, lat)
+       call nfw_get_var_double(filename, ncid, vsst_ID, sst)
+       call nfw_get_var_double(filename, ncid, vstd_ID, std)
+       call nfw_get_var_int(filename, ncid, vmask_ID, mask)
+       print '(1x, a, 2f10.2)', '    range Lon = ', minval(lon), maxval(lon)
+       print '(1x, a, 2f10.2)', '    range Lat = ', minval(lat), maxval(lat)
+       print '(1x, a, 2f10.2)', '    range sst (K) = ', minval(sst), maxval(sst)
+       print '(1x, a, 2i10)',   '    range mask = ', minval(mask), maxval(mask)
+       call nfw_close(filename, ncid)
+       count1=1
+       do i=1,gr%nx
+          do j=1,gr%ny
+            !here we only consider:
+            !data above -30 of lat; valid, within reasonable range,
+            ! and only open ocean (mask == 1)
+            !                 
+            if (lat(j) > -30 .and.&
+                     abs(sst(i,j)-undef_sst(1)) > eps .and.&
+                     mask(i,j) == 1 .and. & 
+                     sst(i,j) > -190 .and. &
+                     sst(i,j) < 4500 .and. &
+                     std(i,j) > 0.0) then
+                   data(count1)%id = 'SST'
+                   data(count1)%d = sst(i,j)*0.01  
+                   data(count1)%ipiv = count1 !whatever it is filled afterwards
+                   data(count1)%jpiv = 1   !whaterver it is filled afterwards
+                   data(count1)%lat=lat(j)
+                   data(count1)%lon=lon(i)
+                   data(count1)%a1 = spherdist(lon(i)-.5*gr%dx,lat(j)-.5*gr%dy,lon(i)+.5*gr%dx,lat(j)+.5*gr%dy)
+                   data(count1)%ns = 1 ! 1 for data with a spatial extent
+                   data(count1)%var = (std(i,j) * 0.01 * 8) ** 2 ! Exaggerate, factor 8
+                   data(count1)%date = 0
+                   data(count1)%depth = 0.0
+                   data(count1)%status = .true.
+                   count1=count1+1
+            endif
+          enddo   !i
+        enddo    !j
+       print*, '    # of obs read = ', count1
+       deallocate(lat, lon, sst, mask)
+    end if ! ex
+    print *, 'MAX var(SST) = ', maxval(data(1 : count1) % var)
+  end subroutine read_MET_SST
+end module m_read_MET_SST

EnKF-MPI-TOPAZ/Prep_Routines/m_read_MET_SST_grid.F90

@@ -0,0 +1,60 @@
+module m_read_MET_SST_grid
+  ! Reads the CLS SST NetCDF dimensions
+contains
+  subroutine read_MET_SST_grid(filename,gr)
+    !use mod_dimensions
+    use mod_grid
+    use nfw_mod
+    implicit none
+
+    character(len=80), intent(in) :: filename
+    type(grid),        intent(out) :: gr
+    logical :: ex
+    !dimension ids
+    integer :: lon_ID,lat_ID
+
+    ! Array dimensions
+    integer :: nblon,nblat
+
+    integer :: ncid
+    real, allocatable :: lat(:), lon(:)
+
+    print *, 'read_MET_SST_grid():'
+
+    gr = default_grid
+    inquire(file=trim(filename),exist=ex)
+    if(ex) then
+         call nfw_open(filename, nf_nowrite, ncid)
+         print *, '  found "', trim(filename), '"...'
+          ! Get dimension id in netcdf file ...
+          call nfw_inq_dimid(filename, ncid, 'lon', lon_ID)
+          call nfw_inq_dimid(filename, ncid, 'lat', lat_ID)
+          ! Get dimension length from id
+          call nfw_inq_dimlen(filename, ncid, lon_ID, nblon)
+          call nfw_inq_dimlen(filename, ncid, lat_ID, nblat)
+          print*, 'Dimensions lon,lat:', nblon, nblat
+          allocate(lon(nblon), lat(nblat))
+          call nfw_inq_varid(filename, ncid, 'lon', lon_ID)
+          call nfw_inq_varid(filename, ncid, 'lat', lat_ID)
+          call nfw_get_var_double(filename, ncid, lon_ID, lon)
+          call nfw_get_var_double(filename, ncid, lat_ID, lat)
+          call nfw_close(filename, ncid)
+
+
+          gr%nx=nblon
+          gr%ny=nblat
+          gr%x0=lon(1)
+          gr%y0=lat(1)
+          gr%dx=lon(2)-lon(1)
+          gr%dy=lat(2)-lat(1)
+
+          gr%reg = .true.
+          gr%order = 2
+          gr%ux = 'm'
+          gr%uy = 'm'
+          gr%set = .true.
+          deallocate(lon,lat)
+    endif
+  end subroutine read_MET_SST_grid
+  
+end module m_read_MET_SST_grid

EnKF-MPI-TOPAZ/Prep_Routines/m_read_OSISAF_data.F90

@@ -0,0 +1,143 @@
+module m_read_OSISAF_data
+
+contains
+
+  ! Reads OSISAF ice drift data
+  ! 2012-11-13: Geir Arne Waagbø (met.no)
+  subroutine read_OSISAF_data(driftfile, gr, data, numdata, var, offset)
+    use nfw_mod
+    use mod_measurement
+    use mod_grid
+    implicit none
+
+    character(*), intent(in) :: driftfile
+    integer, intent(in) :: numdata
+    type(measurement), dimension(numdata),intent(inout) :: data
+    type(grid), intent(in) :: gr
+    real, intent(in) :: var
+    character(len=1), intent(in) :: offset
+
+    integer :: dimids(2)
+    integer , dimension(2) :: dimsizes
+
+    integer :: lon_id, lat_id, dx_id, dy_id, qflag_id
+    real, dimension(:,:), allocatable :: drlon, drlat, drdX, drdY
+    integer, dimension(:,:), allocatable :: qflag
+
+    integer :: ncid
+    real, dimension(1) :: fillval
+
+    integer :: i,j,k,icomp
+    integer :: drnx, drny
+    logical :: valid
+
+    ! Get dimensions of drift file
+    call nfw_open(driftfile, nf_nowrite, ncid)
+    call nfw_inq_varid(driftfile, ncid, 'dX', dx_id)
+    call nfw_inq_vardimid(driftfile, ncid, dx_id, dimids)
+    do i = 1, 2
+       call nfw_inq_dimlen(driftfile, ncid, dimids(i), dimsizes(i))
+    end do
+    drnx=dimsizes(1)
+    drny=dimsizes(2)
+
+    if (gr % reg) then
+       print *,'NB: OSISAF data should be specified as irregular !'
+       print *,'    Currently it is set as regular..'
+       print *,'(read_OSISAF_data)'
+       call exit(1) 
+    end if
+
+    ! Which should match numdata dimension 
+    ! NB !!! Mult by 2 for two vector components
+    if (2*drnx*drny /= numdata .or. 2*drnx*drny /= gr%nx) then
+       print *,'Different dimensions - data file and specified'
+       print *,'dimsizes(1)=',drnx
+       print *,'dimsizes(2)=',drny
+       print *,'nx         =',gr%nx
+       print *,'(read_OSISAF_data)'
+       call exit(1) 
+    end if
+
+    ! Read data from drift file
+    allocate(drlon(drnx,drny))
+    allocate(drlat(drnx,drny))
+    allocate(drdX(drnx,drny))
+    allocate(drdY(drnx,drny))
+    allocate(qflag(drnx,drny))
+
+    call nfw_inq_varid(driftfile, ncid, 'lon', lon_id)
+    call nfw_get_var_double(driftfile, ncid, lon_id, drlon)
+    call nfw_inq_varid(driftfile, ncid, 'lat', lat_id)
+    call nfw_get_var_double(driftfile, ncid, lat_id, drlat)
+    call nfw_inq_varid(driftfile, ncid, 'dX', dx_id)
+    call nfw_get_var_double(driftfile, ncid, dx_id, drdX)
+
+    ! Change dY_v1p4 to dY from version 1.4 of OSISAF product file
+    call nfw_inq_varid(driftfile, ncid, 'dY_v1p4', dy_id)
+    call nfw_get_var_double(driftfile, ncid, dy_id, drdY)
+
+    call nfw_get_att_double(driftfile, ncid, dx_id, '_FillValue', fillval)
+
+    where (abs(drdX - fillval(1)) < 1e-4 * fillval(1))
+       drdX = gr % undef
+    end where
+
+    call nfw_get_att_double(driftfile, ncid, dy_id, '_FillValue', fillval)
+
+    where (abs(drdY - fillval(1)) < 1e-4 * fillval(1))
+       drdY = gr % undef
+    end where
+
+    ! Change status_flag_v1p4 to status_flag from version 1.4 of OSISAF product file
+    call nfw_inq_varid(driftfile, ncid, 'status_flag_v1p4', qflag_id)
+    call nfw_get_var_int(driftfile, ncid, qflag_id, qflag)
+
+    call nfw_close(driftfile, ncid)
+
+    k = 0
+    do icomp = 1, 2
+       do j = 1, drny
+          do i = 1, drnx
+             k = k + 1
+
+             valid = qflag(i,j) == 30 ! Only use observations with quality_flag==30
+             if (icomp==1) then
+                data(k)%id = 'DX'//offset
+                data(k)%d = drdX(i,j)
+                valid = valid .and.  abs((drdX(i,j)-gr%undef) / gr%undef) > 1e-4
+             else
+                data(k)%id = 'DY'//offset
+                data(k)%d = drdY(i,j)
+                valid =  valid .and. abs((drdY(i,j)-gr%undef) / gr%undef) > 1e-4
+             end if
+
+             if (.not. valid .or. mod(i,2)==0 .or. mod(j,2)==0) then
+                ! Skip invalid observations, or observations on grid points with
+                ! even i- or j-indices (to avoid over assimilation)
+                data(k)%d = gr%undef
+             end if
+
+             data(k)%ipiv = i  ! Not really used for ice drift
+             data(k)%jpiv = j  ! Not really used for ice drift
+             data(k)%i_orig_grid = i ! Used for ice drift
+             data(k)%j_orig_grid = j ! Used for ice drift
+             data(k)%lat=drlat(i,j)
+             data(k)%lon=ang180(drlon(i,j))
+             ! Each vector represents the average drift of a 120kmx120km area of sea ice
+             ! The a1 value should be in meters, although other values are in km
+             data(k)%a1 = 1.4*60000 ! 1.4 represents square root of 2
+             data(k)%ns = 1
+             data(k)%var = var ! fom idrft.hdr specification
+             data(k)%depth = 0.0
+             data(k)%status = valid
+          enddo
+       enddo
+    enddo
+    print *, 'Number of data read:', k, gridpoints(gr)
+
+  end subroutine
+
+end module
+
+

EnKF-MPI-TOPAZ/Prep_Routines/m_read_amsr_norsex.F90

@@ -0,0 +1,175 @@
+! File:          m_read_amsr_norsex.F90
+!
+! Created:       ???
+!
+! Last modified: 29/06/2010
+!
+! Purpose:       Reads ICEC data
+!
+! Description:   
+!
+! Modifications:
+!                29/06/2010 PS:
+!                  - set the maximum ICEC to 0.995 to match the model
+!                Prior history:
+!                  Not documented.
+
+ module m_read_amsr_norsex
+! Reads amsr icec from NERSC (norsex)
+! This will only work for northern hemisphere data - some minor corrections
+! are needed for SH data
+
+  integer, parameter, private :: STRLEN = 512
+
+contains
+  subroutine read_amsr_norsex(fname,gr,data,obstype)
+  use mod_grid
+  use mod_measurement
+  implicit none
+  type (grid),      intent(out) :: gr
+  character(len=*) ,intent(in)  :: fname
+  type(measurement), allocatable, intent(out) :: data(:)
+  character(len=5) ,intent(in)  :: obstype
+
+  integer :: i, j,k, rlen
+  integer*1, allocatable :: iofldi1(:,:)
+  integer*4, allocatable :: iofldi4(:,:)
+  real   *4, allocatable, dimension(:,:) :: lon,lat,icec
+  logical :: ex(3)
+
+  ! The grid stuff should be made more consistent - KAL
+  gr = default_grid
+  gr%undef=120.
+  gr%nx=608
+  gr%ny=896
+  gr%order=2
+  gr%ux='12.5 km' !Roughly
+  gr%uy='12.5 km' !Roughly
+  gr%set=.true.
+  print '(a,3e14.3)','undef          : ', gr%undef
+  print *,' No of gridpoints: ', gridpoints(gr)
+
+  ! Test for input files:
+  inquire(exist=ex(1),file='psn12lons_v2.dat')
+  inquire(exist=ex(2),file='psn12lats_v2.dat')
+  inquire(exist=ex(3),file=trim(fname))
+
+  if (any(.not.ex)) then
+     print *,'A file is missing:'
+     print *,'File flag: ',ex(1),' - name: psn12lons_v2.dat'
+     print *,'File flag: ',ex(2),' - name: psn12lats_v2.dat'
+     print *,'File flag: ',ex(3),' - name: '//trim(fname)
+     print *,'(read_amsr_norsex)'
+     call exit(1)
+  end if
+
+
+  ! Allocate fields and read input data
+  allocate(icec   (gr%nx,gr%ny))
+  allocate(lon    (gr%nx,gr%ny))
+  allocate(lat    (gr%nx,gr%ny))
+  allocate(iofldi1(gr%nx,gr%ny))
+  allocate(iofldi4(gr%nx,gr%ny))
+  allocate(data (gr%nx*gr%ny))
+
+  inquire(iolength=rlen) iofldi4
+  open(10,file='psn12lons_v2.dat',status='old',form='unformatted',access='direct',recl=rlen)
+  read(10,rec=1) iofldi4 
+  close(10)
+#if defined (LITTLE_ENDIAN) /* Lon/lat input files are big endian */
+  do j=1,gr%ny
+  do i=1,gr%nx
+     call swapendian2(iofldi4(i,j),4)
+  end do
+  end do
+#endif
+  lon = real(iofldi4,4) / 100000.0_4
+
+
+  inquire(iolength=rlen) iofldi4
+  open(10,file='psn12lats_v2.dat',status='old',form='unformatted',access='direct',recl=rlen)
+  read(10,rec=1) iofldi4 
+  close(10)
+#if defined (LITTLE_ENDIAN) /* Lon/lat input files are big endian */
+  do j=1,gr%ny
+  do i=1,gr%nx
+     call swapendian2(iofldi4(i,j),4)
+  end do
+  end do
+#endif
+  lat = real(iofldi4, 4) / 100000.0_4
+
+  inquire(iolength=rlen) iofldi1
+  open(10,file=trim(fname),status='old',form='unformatted',access='direct',recl=rlen)
+  read(10,rec=1) iofldi1
+  close(10)
+
+  icec=iofldi1
+  where(icec>100)  
+     icec = real(gr % undef, 4)
+  elsewhere
+     icec = icec / 100.0_4
+     !LB tighten observed pack ice 
+     !where (icec>0.9) icec = 1.0
+  end where
+  ! PS 25/06/2010 0.995 is the max allowed by the model
+  where (0.995 <= icec .and. icec <= 1.0)
+     icec = 0.995
+  end where
+
+
+  do j=1,gr%ny
+  do i=1,gr%nx
+ 
+     k=(j-1)*gr%nx +i
+   
+     data(k)%id = obstype
+     data(k)%d = icec(i,j)
+     data(k)%jpiv = j
+     data(k)%ipiv = i
+     data(k)%lon=lon(i,j)
+     data(k)%lat=lat(i,j)
+
+!LB: Data support is assumed = a square grid cell
+!support diameter stored in %a1 (tricky, isn't it ?)
+     data(k)%a1 = 12500. *sqrt(2.) ! AMSR-E grid diagonal
+     data(k)%ns = 1 ! 1 for obs with a spatial extent
+
+     data(k)%status = .not. undefined(data(k)%d,gr) ! active data
+     ! PS 17.06.2010 - increased obs error at the ice edge
+     ! data(k)%var = 0.01 ! KAL 10%
+     data(k) % var = 0.01d0 + (0.5d0 - abs(0.5d0 - icec(i,j))) ** 2
+     data(k) % depth = 0.0
+  end do
+  end do
+
+  call icec2nc(gr % nx, gr % ny, icec, lon, lat)
+end subroutine read_amsr_norsex
+
+subroutine icec2nc(ni, nj, icec, lon, lat)
+  use nfw_mod
+
+  integer, intent(in) :: ni
+  integer, intent(in) :: nj
+  real*4, intent(in) :: icec(ni, nj), lon (ni, nj), lat(ni, nj)
+
+  character(STRLEN) :: fname
+  integer :: ncid
+  integer :: nij_id(2), icec_id, lon_id, lat_id
+
+  fname = 'icec.nc';
+  call nfw_create(fname, nf_clobber, ncid)
+  call nfw_def_dim(fname, ncid, 'ni', ni, nij_id(1));
+  call nfw_def_dim(fname, ncid, 'nj', nj, nij_id(2));
+  call nfw_def_var(fname, ncid,  'icec', nf_float, 2, nij_id, icec_id)
+  call nfw_def_var(fname, ncid,  'lon', nf_float, 2, nij_id, lon_id)
+  call nfw_def_var(fname, ncid,  'lat', nf_float, 2, nij_id, lat_id)
+  call nfw_enddef(fname, ncid)
+
+  call nfw_put_var_real(fname, ncid, icec_id, icec)
+  call nfw_put_var_real(fname, ncid, lon_id, lon)
+  call nfw_put_var_real(fname, ncid, lat_id, lat)
+  call nfw_close(fname, ncid)
+end subroutine icec2nc
+ 
+end module m_read_amsr_norsex

EnKF-MPI-TOPAZ/Prep_Routines/m_read_ifremer_argo.F90

@@ -0,0 +1,663 @@
+! File:          m_read_ifremer_argo.F90
+!
+! Created:       25 Jan 2008
+!
+! Author:        Pavel Sakov
+!                NERSC
+!
+! Purpose:       Read Argo data from NetCDF files from IFREMER into TOPAZ
+!                system.
+!
+! Description:   Data file(s) are defined by the string in the 4th line of
+!                "infile.data". It should have the following format:
+!                <BEGIN>
+!                IFREMER
+!                SAL | TEM
+!                <obs. error variance>
+!                <File name(s) or a wildcard>
+!                <END>
+!                After that:
+!                1. all profiles are read into two arrays,
+!                   pres(1 : nlev, 1 : nprof) and v(1 : nlev, 1 : nprof), where
+!                   nprof is the total number of profiles in all files, and
+!                   nlev is the maximum number of horizontal levels for all
+!                   profiles;
+!                2. bad data (with qc flags other than '1' or '2' is discarded;
+!                3. dry or outside locations are discarded
+!                4. if there close profiles (in the same grid cell), the best
+!                   one (with most data or the most recent) is retained
+!
+! Modifications: 17/08/2010 PS: skip discarding close profiles
+!
+
+module m_read_ifremer_argo
+  implicit none
+
+  integer, parameter, private :: STRLEN = 512
+  real, parameter, private :: SAL_MIN = 32.0
+  real, parameter, private :: SAL_MAX = 37.5
+  real, parameter, private :: DENS_DIFF_MIN = -0.02
+  logical, parameter, private :: DISCARD_CLOSE = .false.
+
+  public read_ifremer_argo
+
+  private data_inquire
+  private data_readfile
+  private potential_density
+  private grid_readxyz
+
+contains
+
+  subroutine read_ifremer_argo(fnames, obstype, variance, nx, ny, data)
+    use mod_measurement
+    use m_oldtonew
+    use m_confmap
+    use m_bilincoeff
+    use m_pivotp
+    use nfw_mod
+    
+    character(*), intent(in) :: fnames
+    character(*), intent(in) :: obstype
+    real(8), intent(in) :: variance
+    integer, intent(in) :: nx, ny
+    type(measurement), allocatable, intent(out) :: data(:)
+
+    character(STRLEN) :: fname
+    integer :: nfile, nprof, nlev
+    real(8), allocatable :: juld(:)
+    character, allocatable :: juld_qc(:)
+    real(8), allocatable :: lat(:), lon(:)
+    character, allocatable :: pos_qc(:)
+    real(8), allocatable :: pres(:,:)
+    character, allocatable :: pres_qc(:,:)
+    real(8), allocatable :: temp(:,:), salt(:, :)
+    character, allocatable :: temp_qc(:,:), salt_qc(:, :)
+    integer, allocatable :: ipiv(:), jpiv(:)
+
+    real(8), dimension(nx, ny) :: modlat, modlon
+    real(8), dimension(nx, ny) :: depths
+
+    integer :: f, l, p, np
+    integer, allocatable :: mask(:)
+    integer, allocatable :: mask2(:, :)
+    integer, allocatable :: fid(:);
+    integer, allocatable :: profid(:)
+    integer, allocatable :: done(:)
+    real(8) :: zmax, Q, Qbest, rho, rho_prev, rho_inc
+    integer :: best
+    integer :: p1
+    
+    integer ngood, ndata
+    real(8) :: latnew, lonnew
+    
+    print *, 'BEGIN read_ifremer_argo()'
+
+    call data_inquire(fnames, nfile, nprof, nlev)
+    print *, '  overall: nprof =', nprof, ', nlev =', nlev
+
+    allocate(juld(nprof))
+    allocate(juld_qc(nprof))
+    allocate(lat(nprof))
+    allocate(lon(nprof))
+    allocate(pos_qc(nprof))
+    allocate(fid(nprof))
+    allocate(profid(nprof))
+    allocate(pres(nlev, nprof))
+    allocate(pres_qc(nlev, nprof))
+    allocate(temp(nlev, nprof))
+    allocate(salt(nlev, nprof))
+    allocate(temp_qc(nlev, nprof))
+    allocate(salt_qc(nlev, nprof))
+
+    p = 1
+    do f = 1, nfile
+       call data_readfile(f, trim(obstype), np, juld(p : nprof),&
+            juld_qc(p : nprof), lat(p : nprof),&
+            lon(p : nprof), pos_qc(p : nprof), pres(1 : nlev, p : nprof),&
+            pres_qc(1 : nlev, p : nprof), temp(1 : nlev, p : nprof),&
+            temp_qc(1 : nlev, p : nprof), salt(1 : nlev, p : nprof),&
+            salt_qc(1 : nlev, p : nprof))
+       fid(p : p + np - 1) = f
+       do l = 1, np
+          profid(p + l - 1) = l
+       end do
+       p = p + np
+    end do
+
+    ! mask <- juld_qc, pos_qc, pres_qc, v_qc
+    !
+    allocate(mask(nprof))
+    mask(:) = 1
+    allocate(mask2(nlev, nprof))
+    mask2(:, :) = 1
+
+    where (juld_qc /= '1' .and. juld_qc /= '2') mask = 0
+    do p = 1, nprof
+       if (mask(p) == 0) then
+          mask2(:, p) = 0
+       end if
+    end do
+    print *, '  after examining JULD_QC:'
+    print *, '    ', count(mask == 1), ' good profiles'
+    print *, '    ', count(mask2 == 1), ' good obs'
+
+    where (pos_qc /= '1' .and. pos_qc /= '2') mask = 0
+    do p = 1, nprof
+       if (mask(p) == 0) then
+          mask2(:, p) = 0
+       end if
+    end do
+    print *, '  after examining POS_QC:'
+    print *, '    ', count(mask == 1), ' good profiles'
+    print *, '    ', count(mask2 == 1), ' good obs'
+
+    ! ipiv, jpiv
+    !
+    allocate(ipiv(nprof))
+    allocate(jpiv(nprof))
+    ipiv(:) = -999
+    jpiv(:) = -999
+    call confmap_init(nx, ny)
+    do p = 1, nprof
+       if (mask(p) == 0) then
+          cycle
+       end if
+       call oldtonew(lat(p), lon(p), latnew, lonnew)
+       call pivotp(lonnew, latnew, ipiv(p), jpiv(p))
+    end do
+    where (ipiv < 1 .or. jpiv < 1 .or. ipiv > nx - 1 .or. jpiv > ny - 1) mask = 0
+    do p = 1, nprof
+       if (mask(p) == 0) then
+          mask2(:, p) = 0
+       end if
+    end do
+    print *, '  after calculaling pivot points:'
+    print *, '    ', count(mask == 1), ' good profiles'
+    print *, '    ', count(mask2 == 1), ' good obs'
+
+    !
+    ! Now examine 3D quality flags; set the mask for a profile to 0 if there
+    ! are no good samples in this profile
+    !
+
+    ! pres_qc
+    !
+    do p = 1, nprof
+       do l = 1, nlev
+          if (pres_qc(l, p) /= '1' .and. pres_qc(l, p) /= '2') then
+             mask2(l, p) = 0
+          end if
+       end do
+       if (count(mask2(:, p) == 1) == 0) then
+          mask(p) = 0
+       end if
+    end do
+    print *, '  after examining PRES_QC:'
+    print *, '    ', count(mask == 1), ' good profiles'
+    print *, '    ', count(mask2 == 1), ' good obs'
+
+    ! <data>_qc
+    !
+    if (trim(obstype) == 'SAL') then
+       do p = 1, nprof
+          do l = 1, nlev
+             if (salt_qc(l, p) /= '1' .and. salt_qc(l, p) /= '2') then
+                mask2(l, p) = 0
+             end if
+          end do
+          if (count(mask2(:, p) == 1) == 0) then
+             mask(p) = 0
+          end if
+       end do
+    else if (trim(obstype) == 'TEM') then
+       do p = 1, nprof
+          do l = 1, nlev
+             if (temp_qc(l, p) /= '1' .and. temp_qc(l, p) /= '2') then
+                mask2(l, p) = 0
+             end if
+          end do
+          if (count(mask2(:, p) == 1) == 0) then
+             mask(p) = 0
+          end if
+       end do
+    end if
+    print *, '  after examining <data>_QC:'
+    print *, '    ', count(mask == 1), ' good profiles'
+    print *, '    ', count(mask2 == 1), ' good obs'
+
+    ! Check for the observation being wet
+    !
+    call grid_readxyz(nx, ny, modlat, modlon, depths)
+    do p = 1, nprof
+       if (mask(p) == 0) then
+          cycle
+       end if
+       do l = 1, nlev
+          if (mask2(l, p) == 0) then
+             cycle
+          end if
+          if (pres(l, p) > depths(ipiv(p), jpiv(p)) .or.&
+               pres(l, p) > depths(ipiv(p) + 1, jpiv(p)) .or.&
+               pres(l, p) > depths(ipiv(p), jpiv(p) + 1) .or.&
+               pres(l, p) > depths(ipiv(p) + 1, jpiv(p) + 1)) then
+             mask2(l, p) = 0
+          end if
+       end do
+       if (count(mask2(:, p) == 1) == 0) then
+          mask(p) = 0
+       end if
+    end do
+    print *, '  after examining for wet cells:'
+    print *, '    ', count(mask == 1), ' good profiles'
+    print *, '    ', count(mask2 == 1), ' good obs'
+
+    ! For salinity, allow SAL_MIN < S < SAL_MAX only in a profile
+    !
+    do p = 1, nprof
+       if (mask(p) == 0) then
+          cycle
+       end if
+       do l = 1, nlev
+          if (mask2(l, p) == 0) then
+             cycle
+          end if
+          if ((trim(obstype) == 'SAL' .and.&
+               (salt_qc(l, p) == '1' .or. salt_qc(l, p) == '2')) .and.&
+               (salt(l, p) < SAL_MIN .or. salt(l, p) > SAL_MAX)) then
+             mask(p) = 0 ! discard the profile
+             mask2(:, p) = 0
+             exit
+          end if
+       end do
+    end do
+    print *, '  after keeping only profiles with salinity within',&
+         SAL_MIN, '<= S <=', SAL_MAX, ":"
+    print *, '    ', count(mask == 1), ' good profiles'
+    print *, '    ', count(mask2 == 1), ' good obs'
+
+    print *, '  discarding convectionally unstable profiles:'
+    do p = 1, nprof
+       if (mask(p) == 0) then
+          cycle
+       end if
+       rho_prev = -999.0
+       do l = 1, nlev
+          if (mask2(l, p) == 0 .or.&
+               (temp_qc(l, p) /= '1' .and. temp_qc(l, p) /= '2') .or.&
+               (salt_qc(l, p) /= '1' .and. salt_qc(l, p) /= '2')) then
+             cycle
+          end if
+          if (rho_prev == -999.0) then
+             rho_prev = potential_density(temp(l, p), salt(l, p))
+             cycle
+          else
+             rho = potential_density(temp(l, p), salt(l, p))
+             rho_inc = rho - rho_prev
+             if (rho_inc < DENS_DIFF_MIN) then
+                open(10, file = 'infiles.txt')
+                do f = 1, fid(p)
+                   read(10, fmt = '(a)') fname
+                end do
+                close(10)
+
+                print *, '    ', trim(fname), ':'
+                print *, '      profile #', profid(p), '( #', p, ')'
+                print *, '      level #', l
+                print *, '      rho increment =', rho_inc
+                mask(p) = 0 ! discard the profile
+                mask2(:, p) = 0
+                exit
+             end if
+             rho_prev = rho
+          end if
+       end do
+    end do
+    print *, '  after discarding unstable profiles:'
+    print *, '    ', count(mask == 1), ' good profiles'
+    print *, '    ', count(mask2 == 1), ' good obs'
+
+    ! Finally, discard redundant observations
+    ! This is a O(n^2) search, which can become a bit long when the number of
+    ! examined profiles becomes really large (say, 10^4)
+    !
+    if (DISCARD_CLOSE) then
+       allocate(done(nprof))
+       done = 0
+       do p = 1, nprof
+          if (mask(p) == 0 .or. done(p) == 1) then
+             cycle
+          end if
+          np = 1
+          profid(np) = p
+          do p1 = p + 1, nprof
+             if (ipiv(p1) == ipiv(p) .and. jpiv(p1) == jpiv(p)) then
+                np = np + 1
+                profid(np) = p1
+                done(p1) = 1
+             end if
+          end do
+          if (np > 1) then
+             ! for each of close profiles find the depth range, number of points
+             ! and the age
+             Qbest = 0.0
+             do p1 = 1, np
+                zmax = 0.0
+                ndata = 0
+                do l = 1, nlev
+                   if (mask2(l, p1) == 1) then
+                      ndata = ndata + 1
+                      if (pres(l, profid(p1)) > zmax) then
+                         zmax =  pres(l, profid(p1))
+                      end if
+                   end if
+                end do
+                Q = min(zmax, 400.0) / 400.0 + min(ndata, 10) / 10
+                if (Q > Qbest) then
+                   best = p1
+                end if
+             end do
+             do p1 = 1, np
+                if (p1 == best) then
+                   cycle
+                end if
+                mask(profid(p1)) = 0
+                mask2(:, profid(p1)) = 0
+             end do
+          end if
+       end do
+       deallocate(done)
+       print *, '  after discarding close profiles:'
+       print *, '    ', count(mask == 1), ' good profiles'
+       print *, '    ', count(mask2 == 1), ' good obs'
+    end if ! DISCARD_CLOSE
+
+    ngood = count(mask2 == 1)
+    allocate(data(ngood))
+    ndata = 0
+    do p = 1, nprof
+       if (mask(p) == 0) then
+          cycle
+       end if
+       do l = 1, nlev
+          if (mask2(l, p) == 0) then
+             cycle
+          end if
+
+          ndata = ndata + 1
+
+          if (ndata > ngood) then
+             print *, 'ERROR: read_ifremer_argo(): programming error'
+             print *, '  p =', p, ', l =', l
+             print *, '  # data =', ndata, ', ngood =', ngood
+             stop
+          end if
+       
+          ! PS: I guess we should not bother about the cost of the
+          ! comparisons below.
+          !
+          if (trim(obstype) == 'SAL') then
+             data(ndata) % d = salt(l, p)
+          else if (trim(obstype) == 'TEM') then
+             data(ndata) % d = temp(l, p)
+          else
+             data(ndata) % d = -999.0
+          end if
+          data(ndata) % var = variance
+          data(ndata) % id = obstype
+          data(ndata) % lon = lon(p)
+          data(ndata) % lat = lat(p)
+          data(ndata) % depth = max(0.0, pres(l, p))
+          data(ndata) % ipiv = ipiv(p)
+          data(ndata) % jpiv = jpiv(p)
+          data(ndata) % ns = 0 ! for a point (not gridded) measurement
+          data(ndata) % date = 0 ! assimilate synchronously
+
+          call bilincoeff(modlon, modlat, nx, ny, lon(p), lat(p), ipiv(p),&
+               jpiv(p), data(ndata) % a1, data(ndata) % a2, data(ndata) % a3,&
+               data(ndata) % a4)
+
+          data(ndata) % status = .true. ! (active)
+          data(ndata) % i_orig_grid = p
+          data(ndata) % j_orig_grid = l
+       end do
+    end do
+
+    if (ndata /= ngood) then
+       print *, 'ERROR: read_ifremer_argo(): programming error'
+       print *, '  ndata =', ndata, ', ngood =', ngood
+       stop
+    end if
+
+    deallocate(juld)
+    deallocate(juld_qc)
+    deallocate(lat)
+    deallocate(lon)
+    deallocate(pos_qc)
+    deallocate(profid)
+    deallocate(pres)
+    deallocate(pres_qc)
+    deallocate(temp)
+    deallocate(salt)
+    deallocate(temp_qc)
+    deallocate(salt_qc)
+    deallocate(mask)
+    deallocate(mask2)
+    deallocate(ipiv)
+    deallocate(jpiv)
+
+    print *, 'END read_ifremer_argo()'
+
+  end subroutine read_ifremer_argo
+
+
+  subroutine data_inquire(fnames, nfile, nprof, nlev)
+    use nfw_mod
+
+    character(*), intent(in) :: fnames
+    integer, intent(inout) :: nfile, nprof, nlev
+
+    character(STRLEN) :: command ! (there may be a limit of 80 on some systems)
+    character(STRLEN) :: fname
+    integer :: ios
+    integer :: ncid
+    integer :: id
+
+    integer :: nprof_this, nlev_this
+
+    nfile = 0
+    nprof = 0
+    nlev = 0
+
+    command = 'ls '//trim(fnames)//' > infiles.txt'
+    call system(command);
+
+    nfile = 0
+    open(10, file = 'infiles.txt')
+    do while (.true.)
+       read(10, fmt = '(a)', iostat = ios) fname
+       if (ios /= 0) then
+          exit
+       end if
+
+       nfile = nfile + 1
+       print *, '  file #', nfile, ' = "', trim(fname), '"'
+
+       call nfw_open(fname, nf_nowrite, ncid)
+
+       ! nprof
+       !
+       call nfw_inq_dimid(fname, ncid, 'N_PROF', id)
+       call nfw_inq_dimlen(fname, ncid, id, nprof_this)
+       print *, '    nprof = ', nprof_this
+
+       ! nlev
+       !
+       call nfw_inq_dimid(fname, ncid, 'N_LEVELS', id)
+       call nfw_inq_dimlen(fname, ncid, id, nlev_this)
+       print *, '    nlev = ', nlev_this
+       
+       nprof = nprof + nprof_this
+       if (nlev_this > nlev) then
+          nlev = nlev_this
+       end if
+
+       call nfw_close(fname, ncid)
+    end do
+    close(10)
+  end subroutine data_inquire
+
+
+  subroutine data_readfile(fid, obstype, nprof, juld_all, juld_qc_all,&
+    lat_all, lon_all, pos_qc_all, pres_all, pres_qc_all, temp_all, temp_qc_all, salt_all, salt_qc_all)
+    use nfw_mod
+
+    integer, intent(in) :: fid
+    character(*), intent(in) :: obstype
+    integer, intent(inout) :: nprof
+    real(8), intent(inout), dimension(:) :: juld_all
+    character, intent(inout), dimension(:) :: juld_qc_all
+    real(8), intent(inout), dimension(:) :: lat_all, lon_all
+    character, intent(inout), dimension(:) :: pos_qc_all
+    real(8), intent(inout), dimension(:,:) :: pres_all
+    character, intent(inout), dimension(:,:) :: pres_qc_all
+    real(8), intent(inout), dimension(:,:) :: temp_all
+    character, intent(inout), dimension(:,:) :: temp_qc_all
+    real(8), intent(inout), dimension(:,:) :: salt_all
+    character, intent(inout), dimension(:,:) :: salt_qc_all
+
+    character(STRLEN) :: fname
+    integer :: f
+    integer :: ncid
+    integer :: id
+    integer :: nlev
+    
+    open(10, file = 'infiles.txt')
+    do f = 1, fid
+       read(10, fmt = '(a)') fname
+    end do
+    close(10)
+
+    print *, '  reading "', trim(fname), '"'
+    
+    call nfw_open(fname, nf_nowrite, ncid)
+
+    ! nprof
+    !
+    call nfw_inq_dimid(fname, ncid, 'N_PROF', id)
+    call nfw_inq_dimlen(fname, ncid, id, nprof)
+
+    ! nlev
+    !
+    call nfw_inq_dimid(fname, ncid, 'N_LEVELS', id)
+    call nfw_inq_dimlen(fname, ncid, id, nlev)
+
+    ! juld
+    !
+    call nfw_inq_varid(fname, ncid, 'JULD', id)
+    call nfw_get_var_double(fname, ncid, id, juld_all(1 : nprof))
+
+    ! juld_qc
+    !
+    call nfw_inq_varid(fname, ncid, 'JULD_QC', id)
+    call nfw_get_var_text(fname, ncid, id, juld_qc_all(1 : nprof))
+
+    ! lat
+    !
+    call nfw_inq_varid(fname, ncid, 'LATITUDE', id)
+    call nfw_get_var_double(fname, ncid, id, lat_all(1 : nprof))
+
+    ! lon
+    !
+    call nfw_inq_varid(fname, ncid, 'LONGITUDE', id)
+    call nfw_get_var_double(fname, ncid, id, lon_all(1 : nprof))
+
+    ! pos_qc
+    !
+    call nfw_inq_varid(fname, ncid, 'POSITION_QC', id)
+    call nfw_get_var_text(fname, ncid, id, pos_qc_all(1 : nprof))
+
+    ! pres
+    !
+    call nfw_inq_varid(fname, ncid, 'PRES', id)
+    call nfw_get_var_double(fname, ncid, id, pres_all(1 : nlev, 1 : nprof))
+
+    ! pres_qc
+    !
+    call nfw_inq_varid(fname, ncid, 'PRES_QC', id)
+    call nfw_get_var_text(fname, ncid, id, pres_qc_all(1 : nlev, 1 : nprof))
+
+    ! temp
+    !
+    call nfw_inq_varid(fname, ncid, 'TEMP', id)
+    call nfw_get_var_double(fname, ncid, id, temp_all(1 : nlev, 1 : nprof))
+
+    ! temp_qc
+    !
+    call nfw_inq_varid(fname, ncid, 'TEMP_QC', id)
+    call nfw_get_var_text(fname, ncid, id, temp_qc_all(1 : nlev, 1 : nprof))
+
+    if (nfw_var_exists(ncid, 'PSAL')) then
+       ! psal
+       !
+       call nfw_inq_varid(fname, ncid, 'PSAL', id)
+       call nfw_get_var_double(fname, ncid, id, salt_all(1 : nlev, 1 : nprof))
+
+       ! psal_qc
+       !
+       call nfw_inq_varid(fname, ncid, 'PSAL_QC', id)
+       call nfw_get_var_text(fname, ncid, id, salt_qc_all(1 : nlev, 1 : nprof))
+    else
+       salt_qc_all = 'E';
+    end if
+
+    call nfw_close(fname, ncid)
+  end subroutine data_readfile
+
+
+  subroutine grid_readxyz(nx, ny, lat, lon, depth)
+    integer, intent(in) :: nx, ny
+    real(8), dimension(nx, ny), intent(inout) :: lat, lon, depth
+
+    logical :: exists
+    character(len = 128) :: fname
+    
+    fname = 'newpos.uf'
+    inquire(file = fname, exist = exists)
+    if (.not. exists) then
+       print *, 'grid_readxyz(): ERROR: "', trim(fname), '" does not exist'
+       stop
+    end if
+    open(10, file = fname, form = 'unformatted', status = 'old')
+    print *, '  grid_readxyz(): reading "', trim(fname), '"...'
+    read(10) lat, lon
+    close(10)
+
+    write(fname, '(a, i3.3, a, i3.3, a)') 'depths', nx, 'x', ny, '.uf'
+    inquire(file = fname, exist = exists)
+    if (.not. exists) then
+       print*, 'grid_readxyz(): ERROR: "', trim(fname), '" does not exist'
+       stop
+    end if
+    open (unit = 10, file = fname, status = 'old', form = 'unformatted')
+    print *, '  grid_readxyz(): reading "', trim(fname), '"...'
+    read(10) depth
+    close(10)
+  end subroutine grid_readxyz
+
+
+  real(8) function potential_density(T, S)
+    real(8), intent(in) :: T, S
+
+    if (T < -2.0d0 .or. T > 40.0d0 .or. S < 0.0d0 .or. S > 42.0d0) then
+       potential_density = -999.0d0
+       return
+    end if
+
+    potential_density =&
+         -9.20601d-2&
+         + T * (5.10768d-2 + S * (- 3.01036d-3)&
+         + T * (- 7.40849d-3 + T * 3.32367d-5 + S * 3.21931d-5))&
+         + 8.05999d-1 * S
+  end function potential_density
+
+end module  m_read_ifremer_argo

EnKF-MPI-TOPAZ/Prep_Routines/m_read_jpl_hice.F90

@@ -0,0 +1,115 @@
+module m_read_jpl_hice
+
+contains
+
+  subroutine read_jpl_hice(fname, obstype, variance, nx, ny, data)
+    use mod_measurement
+    use m_oldtonew
+    use m_confmap
+    use m_bilincoeff
+    use m_pivotp
+    implicit none
+
+    character(*), intent(in) :: fname
+    character(*), intent(in) :: obstype
+    real(8), intent(in) :: variance
+    integer, intent(in) :: nx, ny
+    type(measurement), allocatable, intent(out) :: data(:)
+
+    type(measurement), allocatable :: tmpdata(:)
+    real(8), dimension(nx, ny) :: modlat, modlon
+    real(8), dimension(nx, ny) :: depths
+
+    integer :: npoints
+    integer :: i
+    integer :: nobs
+    real(8) :: lat, lon, tmp1, tmp2, h
+    real(8) :: latnew, lonnew
+    integer :: ipiv, jpiv
+
+    open(101, file = trim(fname))
+    read(101, *) npoints
+    print *, '  ',trim(fname), ': ', npoints, ' data points'
+
+    allocate(tmpdata(npoints))
+    call confmap_init(nx, ny)
+    call grid_readxyz(nx, ny, modlat, modlon, depths)
+
+    nobs = 0
+    do i = 1, npoints
+       read(101, *) lat, lon, tmp1, tmp2, h
+       if (h > 0.0d0 .and. h < 9990.0d0) then
+          call oldtonew(lat, lon, latnew, lonnew)
+          call pivotp(lonnew, latnew, ipiv, jpiv)
+
+          if (ipiv < 1 .or. jpiv < 1 .or. ipiv > nx - 1 .or. jpiv > ny - 1) then
+             cycle
+          end if
+          if (depths(ipiv, jpiv) < 10) then
+             cycle
+          end if
+
+          nobs = nobs + 1
+          tmpdata(nobs) % d = h / 100.0d0
+          tmpdata(nobs) % id = obstype
+          tmpdata(nobs) % var = variance
+          tmpdata(nobs) % lon = lon
+          tmpdata(nobs) % lat = lat
+          tmpdata(nobs) % ipiv = ipiv
+          tmpdata(nobs) % jpiv = jpiv
+          tmpdata(nobs) % ns = 0 ! for a point (not gridded) measurement
+          tmpdata(nobs) % date = 0 ! assimilate synchronously
+
+          call bilincoeff(modlon, modlat, nx, ny, lon, lat, ipiv,&
+               jpiv, tmpdata(nobs) % a1, tmpdata(nobs) % a2, tmpdata(nobs) % a3,&
+               tmpdata(nobs) % a4)
+
+          tmpdata(nobs) % status = .true. ! (active)
+          tmpdata(nobs) % i_orig_grid = -1 ! not used
+          tmpdata(nobs) % j_orig_grid = -1 ! not used
+       end if
+    end do
+    close(101)
+
+    print *, '  ', nobs, ' valid observations'
+
+    allocate(data(nobs))
+    do i = 1, nobs
+       data(i) = tmpdata(i)
+    end do
+    deallocate(tmpdata)
+
+  end subroutine read_jpl_hice
+
+
+  subroutine grid_readxyz(nx, ny, lat, lon, depth)
+    integer, intent(in) :: nx, ny
+    real(8), dimension(nx, ny), intent(inout) :: lat, lon, depth
+
+    logical :: exists
+    character(len = 128) :: fname
+    
+    fname = 'newpos.uf'
+    inquire(file = fname, exist = exists)
+    if (.not. exists) then
+       print *, 'grid_readxyz(): ERROR: "', trim(fname), '" does not exist'
+       stop
+    end if
+    open(10, file = fname, form = 'unformatted', status = 'old')
+    print *, '  grid_readxyz(): reading "', trim(fname), '"...'
+    read(10) lat, lon
+    close(10)
+
+    write(fname, '(a, i3.3, a, i3.3, a)') 'depths', nx, 'x', ny, '.uf'
+    inquire(file = fname, exist = exists)
+    if (.not. exists) then
+       print*, 'grid_readxyz(): ERROR: "', trim(fname), '" does not exist'
+       stop
+    end if
+    open (unit = 10, file = fname, status = 'old', form = 'unformatted')
+    print *, '  grid_readxyz(): reading "', trim(fname), '"...'
+    read(10) depth
+    close(10)
+  end subroutine grid_readxyz
+
+end module m_read_jpl_hice

EnKF-MPI-TOPAZ/Prep_Routines/m_read_metno_icec.F90

@@ -0,0 +1,215 @@
+module m_read_metno_icec
+
+contains
+
+  subroutine read_metno_icec_repro(fname, data, gr)
+    use nfw_mod
+    use mod_measurement
+    use mod_grid
+    implicit none
+
+    character(*), intent(in) :: fname
+    type (measurement), allocatable, intent(out) :: data(:)
+    type(grid), intent(out) :: gr
+
+    logical :: ex
+    integer :: ncid
+    integer :: xc_id, yc_id
+    integer :: nx, ny
+    integer :: lon_id, lat_id, icec_id, std_id, flag_id
+    real, allocatable :: lon(:,:), lat(:,:), icec(:,:), std(:, :)
+    integer, allocatable :: flag(:,:)
+
+    integer :: i, j, nobs
+
+    print *, 'reading "', trim(fname), '"...'
+
+    inquire(file = trim(fname), exist = ex)
+    if (.not. ex) then
+       print *, 'ERROR: file "', trim(fname), '" not found'
+       stop
+    end if
+
+    call nfw_open(fname, nf_nowrite, ncid)
+    call nfw_inq_dimid(fname, ncid, 'xc', xc_id)
+    call nfw_inq_dimid(fname, ncid, 'yc', yc_id)
+    call nfw_inq_dimlen(fname, ncid, xc_id, nx)
+    call nfw_inq_dimlen(fname, ncid, yc_id, ny)
+    print *, '  nx = ', nx
+    print *, '  ny = ', ny
+    allocate(lon(nx, ny))
+    allocate(lat(nx, ny))
+    allocate(icec(nx, ny))
+    allocate(std(nx, ny))
+    allocate(flag(nx, ny))
+    call nfw_inq_varid(fname, ncid, 'lon', lon_id)
+    call nfw_inq_varid(fname, ncid, 'lat', lat_id)
+    call nfw_inq_varid(fname, ncid, 'ice_conc', icec_id)
+    call nfw_inq_varid(fname, ncid, 'standard_error', std_id)
+    call nfw_inq_varid(fname, ncid, 'status_flag', flag_id)
+    call nfw_get_var_double(fname, ncid, lon_id, lon)
+    call nfw_get_var_double(fname, ncid, lat_id, lat)
+    call nfw_get_var_double(fname, ncid, icec_id, icec)
+    call nfw_get_var_double(fname, ncid, std_id, std)
+    call nfw_get_var_int(fname, ncid, flag_id, flag)
+    call nfw_close(fname, ncid)
+
+    print *, 'filling the measurements array...'
+
+    allocate(data(nx * ny))
+
+    ! 0.995 is the max allowed by the model
+    where (9950.0d0 <= icec .and. icec <= 10000.d0)
+       icec = 9950.0d0
+    end where   
+
+
+    nobs = 0
+    do j = 1, ny
+       do i = 1, nx
+          nobs = nobs + 1
+          if (flag(i, j) /= 0) then
+             data(nobs) % status = .false.
+             cycle
+          end if
+          data(nobs) % id = 'ICEC'
+          data(nobs) % d = icec(i, j) * 1d-4
+          data(nobs) % var = max(1d-8 * std(i, j) ** 2, 0.01d0 + (0.5d0 - abs(0.5d0 - data(nobs) % d)) ** 2)
+          data(nobs) % ipiv = i
+          data(nobs) % jpiv = j
+          data(nobs) % lon = lon(i, j)
+          data(nobs) % lat = lat(i, j)
+          data(nobs) % a1 = 1e10
+          data(nobs) % a2 = 1e10
+          data(nobs) % a3 = 1e10
+          data(nobs) % a4 = 1e10
+          data(nobs) % ns = 1
+          data(nobs) % date = 0
+          data(nobs) % depth = 0.0
+          data(nobs) % status = .true.
+       end do
+    end do
+    print *, '  ', nobs, 'primary ICEC observations'
+    print *, '  ', minval(data % d), ' <= icec <= ', maxval(data % d)
+
+    gr = default_grid
+    gr % nx = nx
+    gr % ny = ny
+    gr%reg = .true.
+    gr % order = 2
+    gr%ux = '10 km'
+    gr%uy = '10 km'
+    gr%set = .true.
+
+    deallocate(lat, lon, icec, std, flag)
+  end subroutine read_metno_icec_repro
+
+  subroutine read_metno_icec_norepro(fname, data, gr)
+    use nfw_mod
+    use mod_measurement
+    use mod_grid
+    implicit none
+
+    character(*), intent(in) :: fname
+    type (measurement), allocatable, intent(out) :: data(:)
+    type(grid), intent(out) :: gr
+
+    logical :: ex
+    integer :: ncid
+    integer :: xc_id, yc_id
+    integer :: nx, ny
+    integer :: lon_id, lat_id, icec_id, cfl_id, flag_id
+    real, allocatable :: lon(:,:), lat(:,:), icec(:,:), cfl(:, :)
+    integer, allocatable :: flag(:,:)
+
+    integer :: i, j, nobs
+
+    print *, 'reading "', trim(fname), '"...'
+
+    inquire(file = trim(fname), exist = ex)
+    if (.not. ex) then
+       print *, 'ERROR: file "', trim(fname), '" not found'
+       stop
+    end if
+
+    call nfw_open(fname, nf_nowrite, ncid)
+    call nfw_inq_dimid(fname, ncid, 'xc', xc_id)
+    call nfw_inq_dimid(fname, ncid, 'yc', yc_id)
+    call nfw_inq_dimlen(fname, ncid, xc_id, nx)
+    call nfw_inq_dimlen(fname, ncid, yc_id, ny)
+    print *, '  nx = ', nx
+    print *, '  ny = ', ny
+    allocate(lon(nx, ny))
+    allocate(lat(nx, ny))
+    allocate(icec(nx, ny))
+    allocate(cfl(nx, ny))
+    allocate(flag(nx, ny))
+    call nfw_inq_varid(fname, ncid, 'lon', lon_id)
+    call nfw_inq_varid(fname, ncid, 'lat', lat_id)
+    call nfw_inq_varid(fname, ncid, 'ice_conc', icec_id)
+    call nfw_inq_varid(fname, ncid, 'confidence_level', cfl_id)
+    call nfw_inq_varid(fname, ncid, 'status_flag', flag_id)
+    call nfw_get_var_double(fname, ncid, lon_id, lon)
+    call nfw_get_var_double(fname, ncid, lat_id, lat)
+    call nfw_get_var_double(fname, ncid, icec_id, icec)
+    call nfw_get_var_double(fname, ncid, cfl_id, cfl)
+    call nfw_get_var_int(fname, ncid, flag_id, flag)
+    call nfw_close(fname, ncid)
+
+    print *, 'filling the measurements array...'
+
+    allocate(data(nx * ny))
+
+    ! 0.995 is the max allowed by the model
+    where (9950.0d0 <= icec .and. icec <= 10000.d0)
+       icec = 9950.0d0
+    end where   
+
+
+    nobs = 0
+    do j = 1, ny
+       do i = 1, nx
+          nobs = nobs + 1
+          if (flag(i, j) /= 0 .OR. cfl(i,j) < 4) then
+             data(nobs) % status = .false.
+             cycle
+          end if
+          data(nobs) % id = 'ICEC'
+          data(nobs) % d = icec(i, j) * 1d-4
+          if (cfl(i,j)==4) then
+             data(nobs) % var = 0.25d0
+          else if (cfl(i,j) == 5 ) then 
+             data(nobs) % var = 0.01d0
+          end if
+!          data(nobs) % var =  0.01d0 + (0.5d0 - abs(0.5d0 - data(nobs) % d)) ** 2
+          data(nobs) % ipiv = i
+          data(nobs) % jpiv = j
+          data(nobs) % lon = lon(i, j)
+          data(nobs) % lat = lat(i, j)
+          data(nobs) % a1 = 1e10
+          data(nobs) % a2 = 1e10
+          data(nobs) % a3 = 1e10
+          data(nobs) % a4 = 1e10
+          data(nobs) % ns = 1
+          data(nobs) % date = 0
+          data(nobs) % depth = 0.0
+          data(nobs) % status = .true.
+       end do
+    end do
+    print *, '  ', nobs, 'primary ICEC observations'
+    print *, '  ', minval(data % d), ' <= icec <= ', maxval(data % d)
+
+    gr = default_grid
+    gr % nx = nx
+    gr % ny = ny
+    gr%reg = .true.
+    gr % order = 2
+    gr%ux = '10 km'
+    gr%uy = '10 km'
+    gr%set = .true.
+
+    deallocate(lat, lon, icec, cfl, flag)
+  end subroutine read_metno_icec_norepro
+
+
+end module m_read_metno_icec

EnKF-MPI-TOPAZ/Prep_Routines/m_superobs.F90

@@ -0,0 +1,312 @@
+! File:          m_superobs.F90
+!
+! Created:       02 Sep 2008
+!
+! Author:        Pavel Sakov
+!                NERSC
+!
+! Purpose:       Superobing observations to model grid
+!
+! Description:   Conducts the following operations:
+!                  - determine the number of observations with this tag
+!                  - sort observations according to the pivot values
+!                  - calculate superobs
+!
+! Modifications: 14.10.2009 PS: added cycle over the data age, so that it only
+!                               superobs the data of the same age. Do not set 
+!                               age if you assiilate data of different age in 
+!                               one go.
+!                15.11.2009 PS: fixed a defect at l.102: it should be
+!                               "thisob = obs_now(sorted(o))", not
+!                               "thisob = obs_now(o)"
+!                17.11.2009 PS: extended to handle the 3D case
+
+module m_superobs
+  use mod_measurement
+  use m_bilincoeff
+  implicit none
+
+  integer, parameter, private :: STRLEN = 512
+  logical, parameter, private :: TEST = .false.
+
+  contains
+
+  subroutine superob(obstag, nobs, obs, ni, nj, modlon, modlat, nnewobs, newobs, is3d)
+    character(*), intent(in) :: obstag
+    integer, intent(in) :: nobs
+    type(measurement), intent(inout), dimension(:) :: obs
+    integer, intent(in) :: ni, nj
+    real, dimension(:,:), intent(in) :: modlon, modlat
+    integer, intent(inout) :: nnewobs
+    type(measurement), intent(inout), dimension(:) :: newobs
+    logical, intent(in), optional :: is3d
+
+    integer :: age_min, age_max, nobs_total, nobs_now, age
+    integer :: o, iprev, jprev, kprev, ii, ii_now
+    logical, dimension(nobs) :: mask
+    integer, dimension(nobs) :: sorted
+    type(measurement), dimension(nobs) :: obs_now
+    real(8), dimension(1) :: nobs_real
+    type(measurement) :: thisob
+    real :: n, nmax, valsum, valsqsum, varinvsum, lonsum, latsum, depthsum, valmax, valmin
+    real :: a1sum, a2sum, a3sum, a4sum
+    integer :: nlon_pos, nlon_neg
+    real :: lonsum_abs
+    integer, dimension(nobs) :: kpiv ! vertical index for 3D case
+    integer, dimension(nobs) :: ids ! ids of obs contributing to this superob
+    integer :: fid
+
+    kpiv(1:nobs)=0
+
+    ! find the range of the data age
+    !
+    age_min = minval(obs % date)
+    age_max = maxval(obs % date)
+    print *, 'min age =', age_min
+    print *, 'max age =', age_max
+
+    ! get the total number of observations to process
+    !
+    mask = .false.
+    do o = 1, nobs
+       if (trim(obs(o) % id) == trim(obstag)) then
+          mask(o) = .true.
+       end if
+       obs(o) % orig_id = o
+    end do
+    nobs_total = count(mask)
+    print *, 'total # of obs of all types =', nobs
+    print *, 'total # of obs of type "', trim(obstag), '" =', nobs_total
+
+    if (TEST) then
+       open(101, file = 'superobs.txt', access = 'sequential', status = 'replace')
+    end if
+
+    ii = 0
+    do age = age_min, age_max
+       ! trim() prevents vectorising below
+       mask = .false.
+       do o = 1, nobs
+          if (trim(obs(o) % id) == trim(obstag) .and. obs(o) % date == age .and. obs(o) % status) then
+             mask(o) = .true.
+          end if
+       end do
+
+       nobs_now = count(mask)
+       print *, 'age =', age
+       print *, '  nobs =', nobs_now
+
+       if (nobs_now == 0) then
+          cycle
+       end if
+
+       obs_now(1 : nobs_now) = pack(obs(1 : nobs), mask)
+
+       nobs_real(1) = nobs_now
+       if (.not. present(is3d) .or. .not. is3d) then
+          call sortgriddedobs(nobs_real, obs_now % ipiv, obs_now % jpiv, sorted)
+       else
+          kpiv = z2k(obs_now % depth)
+          call sortgriddedobs3d(nobs_real, obs_now % ipiv, obs_now % jpiv,&
+               kpiv, sorted)
+       end if
+ 
+       iprev = 0
+       jprev = 0
+       kprev = 0
+       nmax = 0
+       ii_now = 0
+       do o = 1, nobs_now + 1
+          if (o <= nobs_now) then
+             thisob = obs_now(sorted(o))
+          else
+             thisob % ipiv = -1 ! to force write of the previous measurement
+          end if
+          if (thisob % ipiv /= iprev .or. thisob % jpiv /= jprev .or. kpiv(sorted(o)) /= kprev) then
+             if (ii_now > 0) then ! write the previous measurement
+                newobs(ii) % d = valsum / n
+                newobs(ii) % var = 1.0d0 / varinvsum
+                newobs(ii) % id = obstag
+                if (nlon_pos == 0 .or. nlon_neg == 0 .or. lonsum_abs / n < 90.0d0) then
+                   newobs(ii) % lon = lonsum / n
+                else
+                   lonsum = lonsum + real(nlon_neg) * 360.0d0;
+                   newobs(ii) % lon = lonsum / n
+                   if (newobs(ii) % lon > 180.0d0) then
+                      newobs(ii) % lon = newobs(ii) % lon - 360.0d0
+                   end if
+                end if
+                newobs(ii) % lat = latsum / n
+                newobs(ii) % depth = depthsum / n
+                newobs(ii) % ipiv = iprev
+                newobs(ii) % jpiv = jprev
+                newobs(ii) % ns = 0 ! not 100% sure
+                newobs(ii) % a1 = a1sum / n
+                newobs(ii) % a2 = a2sum / n
+                newobs(ii) % a3 = a3sum / n
+                newobs(ii) % a4 = a4sum / n
+                newobs(ii) % status = .true.
+                newobs(ii) % i_orig_grid = -1
+                newobs(ii) % j_orig_grid = -1
+                newobs(ii) % h = n
+                newobs(ii) % date = age
+                newobs(ii) % orig_id = ids(1) ! ID of the first ob
+                nmax = max(n, nmax)
+                if (TEST) then
+                   write(101, '(a, g10.3)') 'total # of obs = ', n
+                   write(101, '(a, i6)') '  index = ', ii
+                   write(101, '(a, g10.3)') '  d = ', newobs(ii) % d
+                   write(101, '(a, g10.3)') '  var = ', newobs(ii) % var
+                   write(101, '(a, g10.3)') '  lon = ', newobs(ii) % lon
+                   write(101, '(a, g10.3)') '  lat = ', newobs(ii) % lat
+                   write(101, '(a, i4)') '  ipiv = ', newobs(ii) % ipiv
+                   write(101, '(a, i4)') '  jpiv = ', newobs(ii) % jpiv
+                   write(101, '(a, g10.3)') '  depth = ', newobs(ii) % depth
+                   write(101, '(a, g10.3)') '  a1 = ', newobs(ii) % a1
+                   write(101, '(a, g10.3)') '  a2 = ', newobs(ii) % a2
+                   write(101, '(a, g10.3)') '  a3 = ', newobs(ii) % a3
+                   write(101, '(a, g10.3)') '  a4 = ', newobs(ii) % a4
+                   write(101, '(a)') '---'
+                   call superobs_dump(trim(obstag), ii, ids, int(n))
+                end if
+             end if
+             if (o > nobs_now) then
+                exit
+             end if
+             ii = ii + 1
+             ii_now = ii_now + 1
+             if (TEST) then
+                write(101, '(a, i6)') 'new superob, index = ', ii
+             end if
+             n = 0.0
+             valsum = 0.0d0
+             valsqsum = 0.0d0
+             varinvsum = 0.0d0
+             lonsum = 0.0d0
+             latsum = 0.0d0
+             depthsum = 0.0
+             a1sum = 0.0d0
+             a2sum = 0.0d0
+             a3sum = 0.0d0
+             a4sum = 0.0d0
+             valmax = -1.0d+20
+             valmin = 1.0d+20
+             iprev = thisob % ipiv
+             jprev = thisob % jpiv
+             kprev = kpiv(sorted(o))
+             nlon_pos = 0
+             nlon_neg = 0
+             lonsum_abs = 0.0d0
+          end if
+          n = n + 1.0
+          valsum = valsum + thisob % d
+          valsqsum = valsqsum + (thisob % d) ** 2
+          varinvsum = varinvsum + 1.0 / thisob % var
+          lonsum = lonsum + thisob % lon
+          lonsum_abs = lonsum_abs + abs(thisob % lon)
+          if (thisob % lon >= 0.0) then
+             nlon_pos = nlon_pos + 1
+          else
+             nlon_neg = nlon_neg + 1
+          end if
+          latsum = latsum + thisob % lat
+          depthsum = depthsum + thisob % depth
+          a1sum = a1sum + thisob % a1
+          a2sum = a2sum + thisob % a2
+          a3sum = a3sum + thisob % a3
+          a4sum = a4sum + thisob % a4
+          valmin = min(valmin, thisob % d)
+          valmax = max(valmax, thisob % d)
+          ids(int(n)) = thisob % orig_id;
+          if (TEST) then
+             write(101, '(a, i6)') '  obs index = ', sorted(o)
+             write(101, '(a, g10.3)') '    d = ', thisob % d
+             write(101, '(a, g10.3)') '    var = ', thisob % var
+             write(101, '(a, g10.3)') '    lon = ', thisob % lon
+             write(101, '(a, g10.3)') '    lat = ', thisob % lat
+             write(101, '(a, i4)') '    ipiv = ', thisob % ipiv
+             write(101, '(a, i4)') '    jpiv = ', thisob % jpiv
+             write(101, '(a, g10.3)') '    depth = ', thisob % depth
+             write(101, '(a, g10.3)') '    a1 = ', thisob % a1
+             write(101, '(a, g10.3)') '    a2 = ', thisob % a2
+             write(101, '(a, g10.3)') '    a3 = ', thisob % a3
+             write(101, '(a, g10.3)') '    a4 = ', thisob % a4
+          end if
+       end do ! obs for this age
+       print *, '  nsuperobs =', ii_now
+    end do ! age
+    if (TEST) then
+       close(101)
+    end if
+
+    nnewobs = ii
+    print *, 'Superobing("', trim(obstag), '"):'
+    print *, '  ', nobs, 'observations ->', nnewobs, 'observations'
+    print *, '  max # of obs found in a grid cell  =', int(nmax)
+  end subroutine superob
+
+
+  function z2k(z)
+    real, intent(in), dimension(:) :: z
+    integer, dimension(size(z)) :: z2k
+
+    integer :: i, nz
+
+    nz = size(z)
+
+    do i = 1, nz
+       if (z(i) < 3.0d0) then
+          z2k(i) = 1
+       elseif (z(i) < 6.0d0) then
+          z2k(i) = 2
+       elseif (z(i) < 10.0d0) then
+          z2k(i) = 3
+       elseif (z(i) < 100.0d0) then
+          z2k(i) = int(z(i) / 10.0d0) + 3
+       elseif (z(i) < 1000.0d0) then
+          z2k(i) = int(z(i) / 25.0d0) + 9
+       else
+          z2k(i) = int(z(i) / 50.0d0) + 29
+       end if
+    end do
+  end function z2k
+
+
+  subroutine superobs_dump(tag, id, ids, n)
+    use nfw_mod
+
+    character(*) :: tag
+    integer, intent(in) :: id
+    integer, intent(in) :: ids(n)
+    integer, intent(in) :: n
+
+    character(STRLEN) :: fname
+    character(64) :: dname
+    character(64) :: vname
+    integer :: ncid, did(1), vid
+
+    if (id > NF_MAX_DIMS) then
+       return
+    end if
+
+    write(fname, '(a, a, a)') 'superobs-', trim(tag), '.nc'
+    if (id == 1) then
+       print *, 'dumping obs ids for each superob to "', trim(fname), '"'
+       call nfw_create(fname, nf_clobber, ncid)
+    else
+       call nfw_open(fname, nf_write, ncid)
+       call nfw_redef(fname, ncid)
+    end if
+
+    write(dname, '(a,i0)') 'd', id
+    call nfw_def_dim(fname, ncid, trim(dname), n, did(1))
+    write(vname, '(a,i0)') 'v', id
+    call nfw_def_var(fname, ncid, trim(vname), nf_int, 1, did(1), vid)
+    call nfw_enddef(fname, ncid)
+
+    call nfw_put_var_int(fname, ncid, vid, ids)
+
+    call nfw_close(fname, ncid)
+  end subroutine superobs_dump
+
+end module m_superobs

EnKF-MPI-TOPAZ/Prep_Routines/m_write_wet_file.F90

@@ -0,0 +1,37 @@
+module m_write_wet_file
+
+contains 
+
+  subroutine write_wet_file(obs, nrobs)
+    use mod_measurement
+    implicit none
+
+    type (measurement), intent(inout) :: obs(:)
+
+    integer, intent(in):: nrobs
+    integer j, i, nrshow
+    logical ex 
+
+    nrshow = max(nrobs / 10, 1)
+    print *, '10 observations:'
+    print '(a)','    #    obs       var    id      lon   lat  depth   ipiv  jpiv   nsup'//&
+         '  4-bilin-coeffs    active  orig (i,j)    N    age orig_id'
+    inquire(iolength = i) obs(1)
+    open (11, file = 'observations.uf', status = 'replace',&
+         form = 'unformatted', access = 'direct', recl = i)
+
+    do j = 1, nrobs
+       write(11, rec = j) obs(j) 
+       if (obs(j) % d > 1.01 .and. trim(obs(j) % id) == 'ICEC') then
+          print *, obs(j) % lon, obs(j) % lat, obs(j) % d, obs(j) % var
+       end if
+       if (mod(j, nrshow) == 0) then
+          print '(i6,2g10.2,a6,3f6.1,3i6,4f5.1,l5,2i7,f7.1,i5,i8)', j, obs(j)
+       end if
+    enddo
+    close(11)
+    print *, 'Observations printed to file observation.uf'
+  end subroutine write_wet_file
+
+end module m_write_wet_file
+

EnKF-MPI-TOPAZ/Prep_Routines/makefile

@@ -0,0 +1,89 @@
+MPI = NO
+include ../make.inc
+
+SHELL = /bin/bash
+VPATH = ..:.:TMP
+
+PROGS=prep_obs
+
+all: $(PROGS)
+
+PREP_SRC_F90 = mod_angles.F90\
+byteswapper.F90\
+m_confmap.F90\
+m_bilincoeff.F90\
+m_get_def_wet_point.F90\
+m_nf90_err.F90\
+m_oldtonew.F90\
+m_pivotp.F90\
+m_read_CERSAT_data.F90\
+m_read_OSISAF_data.F90\
+m_read_CLS_SLA.F90\
+m_read_CLS_TSLA.F90\
+m_read_MET_SST.F90\
+m_read_CLS_SSH.F90\
+m_read_CLS_SST.F90\
+m_read_CLS_SST_grid.F90\
+m_read_MET_SST_grid.F90\
+m_read_CLS_TSLA_grid.F90\
+m_read_CLS_data.F90\
+m_read_CLS_header.F90\
+m_read_FFI_glider.F90\
+m_read_ifremer_argo.F90\
+m_read_amsr_norsex.F90\
+m_read_metno_icec.F90\
+m_read_jpl_hice.F90\
+m_superobs.F90\
+m_uobs.F90\
+m_write_wet_file.F90\
+mod_grid.F90\
+nfw.F90\
+qmpi.F90
+
+PREP_OBS_SRC_F90 = $(PREP_SRC_F90)\
+mod_measurement.F90\
+m_spherdist.F90\
+m_parse_blkdat.F90\
+m_get_mod_grid.F90\
+p_prep_obs.F90
+
+PREP_OBS_SRC_F = mod_raw_io.F
+
+PREP_OBS_SRC_C = superobs.c\
+superobs3d.c
+
+PREP_OBS_OBJ = $(PREP_OBS_SRC_C:.c=.o) $(PREP_OBS_SRC_F90:.F90=.o) $(PREP_OBS_SRC_F:.F=.o)
+
+m_bilincoeff.o: m_oldtonew.o
+m_get_def_wet_point.o: m_pivotp.o m_confmap.o m_spherdist.o mod_measurement.o mod_grid.o
+m_get_mod_grid.o: mod_raw_io.o
+m_read_CERSAT_data.o: nfw.o
+m_read_CLS_TSLA.o: nfw.o
+m_read_MYO_TSLA.o: nfw.o
+p_prep_obs.o: m_uobs.o
+m_uobs.o: qmpi.o
+
+prep_obs: $(PREP_OBS_OBJ)
+	@echo "->prep_obs"
+	@cd ./TMP; $(LD) $(LINKFLAGS) -o ../prep_obs $(PREP_OBS_OBJ) $(LIBS)
+
+$(PREP_OBS_OBJ): makefile MODEL.CPP
+
+clean:
+	@rm -f TMP/*.f  TMP/*.o TMP/*.f90 TMP/*.h TMP/*.mod $(PROGS)
+
+%.o: %.F90
+	@echo "  $*".F90
+	@rm -f ./TMP/$*.f90
+	@cat MODEL.CPP $< | $(CPP) $(CPPFLAGS) > ./TMP/$*.f90
+	@cd ./TMP; $(CF90) -c $(FFLAGS) $(F90FLG) -o $*.o $*.f90
+
+%.o: %.F
+	@echo "  $*".F
+	@rm -f ./TMP/$*.f
+	@cat MODEL.CPP $< | $(CPP) $(CPPFLAGS) > ./TMP/$*.f
+	@cd ./TMP; $(CF77) -c $(FFLAGS) $(F77FLG) -o $*.o $*.f 2> /dev/null
+
+%.o: %.c
+	@echo "  $*".c
+	@cd ./TMP ; $(CC) -c $(CFLAGS) -o $*.o -I.. -I../.. ../$*.c

EnKF-MPI-TOPAZ/Prep_Routines/mod_angles.F90

@@ -0,0 +1,31 @@
+! Subprograms for the conversion of angles. 
+module mod_angles
+
+contains
+   
+   function ang360(ang)
+   ! Maps arbitrary angle to [0, 360) degrees.
+
+      real ang360
+
+      real, intent(in) :: ang
+
+      ang360 = mod(ang, 360.0) - (sign(1.0,ang)-1.0)*180.0
+
+   end function ang360
+
+   function ang180(ang)
+   ! Maps arbitrary angle to [-180, 180) degrees.
+   ! Use this whenever two angles are subtracted.
+   ! Requires ang360.
+
+      real ang180
+
+      real, intent(in) :: ang
+
+      ang180 = ang360(ang)
+      ang180 = ang180 - 180.0*(sign(1.0,ang180-180.0)+1.0)
+
+   end function ang180
+
+end module mod_angles

EnKF-MPI-TOPAZ/Prep_Routines/mod_grid.F90

@@ -0,0 +1,293 @@
+module mod_grid
+! Contains the type definition for regular (or irregular grids) together
+! with a selection of subprograms for extracting information about the
+! grid. 
+! 
+! 28.1.99, Oyvind.Breivik@nrsc.no.
+!
+! Future extensions: function checkgrid returns zero if grid contains errors
+! or is not set. Include function overloading so that checkgrid may return both
+! integer and real.
+
+!!! Module
+
+use mod_angles
+
+!!! Type definition
+
+   ! Type grid contains information for constructing a 1D, 2D, or 3D grid. The 
+   ! grid may be periodic and physical units may be added to keep track of
+   ! the physical dimensions of start points and resolution of the grid.
+   !
+   ! Oyvind Breivik, 30.12.98.
+
+   type grid
+      integer :: nx, ny, nz ! No of grid points 
+      real    :: dx, dy, dz ! Resolution 
+      real    :: x0, y0, z0 ! Start point (lower left)
+      real    :: undef      ! Undefined value, typically 999.0
+      integer :: order      ! 1D, 2D or 3D grid? Default is 2.
+      logical :: px, py, pz ! Periodic grid in x, y, z? Default is .false.
+      logical :: reg        ! Regular grid? Default is .true.
+                            ! If not, order should be 1, indicating an
+                            ! array of unevenly spaced data rather than a
+                            ! proper grid. In this case, resolution and
+                            ! start point become meaningless.
+      logical :: set        ! Grid initialized or containing default settings?
+      character(len=10) :: ux, uy, uz ! Physical units, 'deg' denotes degrees,
+                                      ! default is '1', nondimensional.
+   end type grid
+
+   type (grid), parameter :: default_grid = grid(0, 0, 0, 0.0, 0.0, &
+      0.0, 0.0, 0.0, 0.0, 999.0, 0, .false., .false., .false., &
+      .true., .false., '1', '1', '1')
+
+contains
+
+!!! Subprograms
+
+   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   function gridpoints(gr)
+   ! Calculates the total number of grid points N in a regular grid of
+   ! type grid or an irregular array of type grid. Returns zero if grid is not
+   ! initialized.
+
+   ! Oyvind Breivik, 30.12.98.
+
+   !!! Interface
+
+      integer gridpoints
+
+      type (grid), intent (in) :: gr
+
+      select case (gr%order)
+         case (1)
+            gridpoints = gr%nx
+         case (2)
+            gridpoints = gr%nx*gr%ny
+         case (3)
+            gridpoints = gr%nx*gr%ny*gr%nz
+      end select
+
+      if (.not. gr%reg) then ! Irregular grid?
+         gridpoints = gr%nx
+      end if
+
+      if (.not. gr%set) then ! Grid initialized or containing default values?
+         gridpoints = 0      ! If not initialized, return zero.
+      end if
+
+   end function gridpoints
+
+
+   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   function gridindex(x,dimid,gr)
+   ! Finds corresponding grid index for coordinate x for grid dimension dimid, 
+   ! where dimid = 1 denotes x, dimid = 2
+   ! denotes y, and dimid = 3 denotes z. If dimid < 0, the grid index is
+   ! rounded down using INT, so that the corresponding grid point is ``to
+   ! the left'' of x. Otherwise NINT is used and the nearest grid point is
+   ! found. 
+   !
+   ! A return value of zero indicates that x is out of range or grid not 
+   ! initialized.
+   ! Note that (x-x0) is mapped to [-180, 180] degrees if and only if the
+   ! variable ux, uy, or uz (depending again on dimid) equals 'deg'. This is
+   ! to ensure that crossing the zero longitude branch cut is handled correctly.
+   ! A return value of -1 indicates that dimid is illegal (greater than the
+   ! order of the grid).
+   !
+   ! Requires module mod_angles.
+
+   !!! Interface
+
+      integer gridindex
+
+      real, intent (in)        :: x
+      integer, intent (in)     :: dimid
+      type (grid), intent (in) :: gr
+
+   !!! Locals
+
+      real    :: x0, x1, dx, e
+      integer :: nx
+      logical :: closest, deg
+
+   !!! Initialize
+
+      closest = (dimid > 0)
+
+      select case (abs(dimid))  ! Choose correct grid dimension
+         case (1) 
+            x0 = gr%x0
+            dx = gr%dx
+            nx = gr%nx
+            deg = (gr%ux == 'deg')
+         case (2)
+            x0 = gr%y0
+            dx = gr%dy
+            nx = gr%ny
+            deg = (gr%uy == 'deg')
+         case (3)
+            x0 = gr%z0
+            dx = gr%dz
+            nx = gr%nz
+            deg = (gr%uz == 'deg')
+      end select
+
+      x1 = x - x0
+
+      if (closest) then
+         e = dx/2          ! Small value epsilon
+      else
+         e = 0.0
+      end if
+
+      if (deg) then
+         x1 = ang360(x1+e) ! Adding dx/2 is a trick to avoid the branch cut
+         x1 = x1-e         ! when finding the closest grid point.
+      end if
+
+      if (.not. closest) then
+         x1 = x1 - dx/2       ! Round down
+      end if
+
+      gridindex = nint(x1/dx) + 1
+
+      if (gridindex < 1 .or. gridindex > nx) then
+         gridindex = 0
+      end if
+
+      if (abs(dimid) > gr%order) then
+         gridindex = -1
+      end if
+
+      if (.not. gr%set) then
+         gridindex = 0
+      end if
+
+   end function gridindex
+
+
+   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   function gridpos(i,dimid,gr)
+   ! Returns the position of grid node i along dimension dimid in grid.
+   !
+   ! If dimid < 0 and the physical unit of the grid is degrees, 
+   ! -180 <= gridpos < 180 [deg]. Otherwise, 0 <= gridpos < 360 [deg].
+   !
+   ! Requires module mod_angles.
+
+   !!! Interface 
+
+      real gridpos
+
+      integer,     intent (in) :: i, dimid
+      type (grid), intent (in) :: gr
+
+   !!! Locals
+
+      real x0, dx
+      logical deg
+
+      select case (abs(dimid))
+         case (1)
+            x0 = gr%x0
+            dx = gr%dx
+            deg = (gr%ux == 'deg')
+         case (2)
+            x0 = gr%y0
+            dx = gr%dy
+            deg = (gr%uy == 'deg')
+         case (3)   
+            x0 = gr%z0
+            dx = gr%dz
+            deg = (gr%uz == 'deg')
+      end select
+
+      gridpos = x0 + real(i-1)*dx
+
+      if (deg) then
+         if (dimid < 0) then
+            gridpos = ang180(gridpos)
+         else
+            gridpos = ang360(gridpos)
+         end if
+      end if
+
+   end function gridpos
+
+
+   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   function ingrid(x,dimid,gr)
+   ! Is x within [x0, x1]? Here x0 and x1 denote the physical 
+   ! bounds of the grid along dimension dimid. If dimid < 0 then ingrid
+   ! checks the interval [-dx/2+x0, x1+dx/2] instead.
+   !
+   ! Requires module mod_angles.
+
+   !!! Interface
+
+      logical ingrid
+
+      real,        intent (in) :: x
+      integer,     intent (in) :: dimid
+      type (grid), intent (in) :: gr
+
+   !!! Locals
+
+      real x0, x1, dx
+      integer nx
+      logical deg
+
+      select case (abs(dimid))
+         case (1)
+            dx = gr%dx
+            x0 = gr%x0
+            nx = gr%nx
+            deg = (gr%ux == 'deg')
+         case (2)
+            dx = gr%dy
+            x0 = gr%y0
+            nx = gr%ny
+            deg = (gr%uy == 'deg')
+         case (3)
+            dx = gr%dz
+            x0 = gr%z0
+            nx = gr%nz
+            deg = (gr%uz == 'deg')
+      end select
+
+      x1 = gridpos(nx,dimid,gr)
+
+      if (dimid < 0) then
+         x0 = x0 - dx/2
+         x1 = x1 + dx/2
+      end if
+
+      ingrid = (x0 <= x) .and. (x <= x1)
+
+      if (deg) then
+         ingrid = ang360(x1-x0) >= ang360(x-x0)
+      end if
+
+      ingrid = ingrid .and. gr%set
+         
+   end function ingrid
+
+   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   function undefined(d,gr)
+   ! True if d == gr%undef.
+
+      logical undefined
+
+      real, intent (in) :: d
+      type (grid), intent (in) :: gr
+
+      undefined = abs(d-gr%undef) < 0.01
+
+   end function undefined
+
+
+   
+end module mod_grid

EnKF-MPI-TOPAZ/Prep_Routines/p_prep_obs.F90

@@ -0,0 +1,451 @@
+! File :         p_prep_obs.F90
+!
+!                Created: unknown
+!
+! Author:        unknown
+!
+! Purpose:       Read data from different data sources and convert it to
+!                type(measurement).
+!
+! Description:   The code calls different subroutines for particular types of
+!                input data, depending on the source, observation type and
+!                format. The output is the array of type(measurement) that
+!                contains, in particular, pivot points and bilinear
+!                interpolation coefficients for each observation. This array
+!                is written to "observations.uf" in binary format.
+!
+! Modifications: 30/01/2008 - Pavel Sakov gave a trim (formatted) -- sorry
+!                  for that, could not stand -- and modified to allow in-situ
+!                  argo data from ifremer.
+!                02/09/2008 - Pavel Sakov added superobing for SST and SLA data
+!                17/08/2010 PS - turned (3D) superobing on for Argo obs
+!                09/11/2012 Geir Arne Waagbo: Added support for OSISAF ice drift obs
+
+program p_prep_obs
+  use mod_measurement
+  use mod_grid
+  use m_read_CLS_header
+  use m_read_CLS_data
+  use m_read_CLS_SST_grid
+  use m_read_MET_SST_grid
+  use m_read_CLS_TSLA_grid
+  use m_read_CLS_SST
+  use m_read_CLS_SSH
+  use m_read_CLS_SLA
+  use m_read_CLS_TSLA
+  use m_read_MET_SST
+  use m_read_CERSAT_data
+  use m_read_OSISAF_data
+  use m_read_ifremer_argo
+  use m_read_jpl_hice
+  use m_read_FFI_glider
+  use m_read_metno_icec
+  use m_get_def_wet_point
+  use m_write_wet_file
+  use m_get_mod_grid
+  use m_parse_blkdat
+  use m_read_amsr_norsex
+  use m_superobs
+  use m_uobs
+  implicit none
+
+  integer, parameter :: STRLEN = 512
+
+  type (measurement), allocatable :: data(:)
+  type (measurement), allocatable :: obs(:)
+  type (grid) :: gr
+
+  integer :: nx, ny
+  real, allocatable, dimension(:,:) :: depths, modlat, modlon
+  integer, parameter :: maxobs = 5000000
+  character(STRLEN) :: fname, fnamehdr, dataformat, producer
+  character(len=3) :: form
+  character(len=5) :: obstype
+  character(len=1) :: offset
+
+  integer :: nrobs
+  integer :: grpoints, k
+  real :: factor, var
+  real :: rdummy, mindx, meandx
+
+  logical :: data_eq_obs
+
+  ! superobs
+  logical :: dosuperob
+  logical :: is3d
+  integer :: nrsobs
+  type(measurement), allocatable :: sobs(:)
+
+  integer :: i
+  integer :: nthisobs
+  integer, allocatable, dimension(:) :: thisobs
+
+  gr = default_grid
+  data_eq_obs = .false.
+
+  open(10, file = 'infile.data')
+  read(10, '(a)') producer
+  read(10, '(a)') obstype
+  read(10, '(a)') fnamehdr
+  read(10, '(a)') fname
+  close(10)
+
+  print *, 'Data producer: ', trim(producer)
+  print *, 'Data to be processed for TOPAZ: ', trim(obstype)
+  print *, 'Filenames to be processed are: "', trim(fnamehdr), '" "', trim(fname), '"'
+  print *, 'Result of processing is stored in temporary file "observation.uf"'
+
+  ! Get grid dimensions from blkdat.input
+  !
+  call parse_blkdat('idm   ', 'integer', rdummy, nx)
+  call parse_blkdat('jdm   ', 'integer', rdummy, ny)
+  allocate(depths(nx, ny))
+  allocate(modlon(nx, ny))
+  allocate(modlat(nx, ny))
+
+  dosuperob = .false.
+  is3d = .false.
+
+  ! Fill the "data" array by calling subroutines specific for the producer
+  ! and observation type
+  !
+  if (trim(producer) == 'Reynolds') then
+
+     if (trim(obstype) == 'SST') then
+        dosuperob = .true.
+        call read_CLS_header(fnamehdr, gr, dataformat, form, factor, var)
+        grpoints = gr % nx * gr % ny
+        allocate(data(grpoints))
+        allocate(obs(maxobs))
+        call read_CLS_data(fname, obstype, dataformat, gr, form, data, factor, var)
+        print*, 'Reynolds- ', obstype, ' data has been scaled by a factor = ', factor  
+     else
+        stop 'ERROR: Reynolds only produce SST'
+     endif
+
+  else if (trim(Producer) == 'MET') then
+
+     if (trim(obstype) == 'SST') then
+        dosuperob = .true.
+        call read_MET_SST_grid(fnamehdr, gr)
+        grpoints = gr % nx * gr % ny
+        allocate(data(grpoints))
+        allocate(obs(maxobs))
+        call read_MET_SST(fname, gr, data)
+     else
+        stop 'ERROR: OSTIA (MET) only produces SST'
+     endif
+
+  else if (trim(Producer) == 'NSIDC-AMSR') then
+
+     if (trim(obstype) == 'ICEC') then
+        dosuperob = .true.
+        call read_amsr_norsex(fname, gr, data, obstype)
+        allocate (obs(maxobs))
+     else
+        print *, 'No ',obstype, ' data from:', Producer
+        stop  'ERROR: p_prep_obs'
+     endif
+
+  else if (trim(Producer) == 'METNO') then
+
+     if (trim(obstype) == 'ICEC') then
+        dosuperob = .true.
+        call read_metno_icec_repro(fname, data, gr)
+        allocate (obs(size(data)))
+     elseif (index(obstype,'idrf')>0) then
+        print *, 'OSISAF Ice Drift: ', obstype
+        offset = obstype(5:5)
+        print *, 'Offset: ', offset ! The number of days before analysis day
+        dosuperob = .false.
+        call read_CLS_header(fnamehdr, gr, dataformat, form, factor, var)
+        grpoints = gr % nx ! NB - 2 vector components - irregular grid
+        allocate(data(grpoints))
+        allocate(obs(maxobs))
+        call read_OSISAF_data(trim(fname), gr, data, grpoints, var, offset)
+        print *, producer, obstype, 'data has been scaled by a factor = ', factor
+     else
+        print *, 'There can be no ', obstype,' data from', Producer
+        stop
+     endif
+
+  elseif (trim(producer) == 'CLS') then
+
+     if (trim(obstype) == 'SLA') then
+        dosuperob = .true.
+        ! call read_CLS_SST_grid() here because SST data grid has the same
+        ! structure
+        call read_CLS_SST_grid(fnamehdr, gr)
+        grpoints = gr % nx * gr % ny
+        allocate(data(grpoints))
+        allocate(obs(maxobs))
+        call read_CLS_SLA(fname, gr, data)
+  
+     elseif (trim(obstype) == 'SSH') then
+        dosuperob = .true.
+        call read_CLS_SST_grid(fnamehdr, gr)
+        grpoints = gr % nx * gr % ny
+        allocate(data(grpoints))
+        allocate(obs(maxobs))
+        call read_CLS_SSH(fname, gr, data)
+
+     elseif (trim(obstype) == 'SST') then
+        dosuperob = .true.
+        call read_CLS_SST_grid(fnamehdr, gr)
+        grpoints = gr % nx * gr % ny
+        allocate(data(grpoints))
+        allocate(obs(maxobs))
+        call read_CLS_SST(fname, gr, data)
+
+     elseif (trim(obstype) == 'TSLA') then
+        dosuperob = .true.
+        call read_CLS_TSLA_grid(fnamehdr, gr)
+        print *, 'read_CLS_TSLA_grid finished, total # of obs = ', gr % nx 
+        grpoints = gr % nx 
+        allocate(data(grpoints))
+        allocate(obs(maxobs))
+        call read_CLS_TSLA(fname,gr,data)
+     else
+        print *, 'data of type "', trim(obstype),'"  from producer "', producer, '" is not handled'
+        stop  'ERROR: p_prep_obs'
+     endif
+
+  else if (trim(producer) == 'NSIDC') then
+     if (trim(obstype) == 'ICEC') then
+        dosuperob = .true.
+        call read_CLS_header(fnamehdr, gr, dataformat, form, factor, var)
+        grpoints = gr % nx * gr % ny
+        allocate(data(grpoints))
+        allocate(obs(maxobs))
+        call read_CLS_data(fname, obstype, dataformat, gr, form, data, factor, var)
+        print *, producer, obstype, 'data has been scaled by a factor = ', factor  
+     else
+        print *, 'no data of type "', trim(obstype),'"  from producer "', producer, '" is not handled'
+        stop  'ERROR: p_prep_obs'
+     endif
+
+  else if (trim(producer) == 'CERSAT') then
+     if (trim(obstype) == 'idrft') then
+        dosuperob = .false.
+        call read_CLS_header(fnamehdr, gr, dataformat, form, factor, var)
+        grpoints = gr % nx ! NB - 2 vector components - irregular grid
+        allocate(data(grpoints))
+        allocate(obs(maxobs))
+        call read_CERSAT_data(trim(fname), gr, data, grpoints, var)
+        print *, producer, obstype, 'data has been scaled by a factor = ', factor  
+     else
+        print *, 'no data of type "', trim(obstype),'"  from producer "', producer, '" is not handled'
+        stop 'ERROR: p_prep_obs'
+     endif
+
+  elseif (trim(producer) == 'IFREMER') then
+
+     dosuperob = .true.
+     is3d = .true.
+     read(fnamehdr, *) var
+     print *, 'variance =', var
+     call read_ifremer_argo(fname, obstype, var, nx, ny, data)
+
+     ! PS: This is a flag to denote that read_ifremer_argo() takes care of
+     ! filling type(measurement) array "data" in a correct way, and it should
+     ! not be re-processed by calling get_def_wet_point(). This may not match
+     ! the ideology behind the workflow adopted in this module and may be
+     ! changed in future.
+     !
+     data_eq_obs = .true.
+
+  elseif (trim(producer) == 'JPL') then
+
+     dosuperob = .true.
+     is3d = .false.
+     read(fnamehdr, *) var
+     print *, 'variance = ', var
+     call read_jpl_hice(fname, obstype, var, nx, ny, data)
+     ! see the comment for producer = IFREMER
+     data_eq_obs = .true.
+
+  elseif (trim(producer) == 'FFI') then
+
+     dosuperob = .true.
+     is3d = .true.
+     read(fnamehdr, *) var
+     print *, 'variance =', var
+     call read_FFI_glider(fname, obstype, var, nx, ny, data)
+     data_eq_obs = .true.
+
+  elseif (trim(producer) == 'MYO') then
+
+    if (trim(obstype) == 'TSLA') then
+        dosuperob = .true.
+        call read_MYO_TSLA_grid(fnamehdr, gr)
+        print *, 'read_CLS_TSLA_grid finished, total # of obs = ', gr % nx
+        grpoints = gr % nx
+        allocate(data(grpoints))
+        allocate(obs(maxobs))
+        call read_MYO_TSLA(fnamehdr,fname,gr,data)
+        print *, 'read_MYO_TSLA finished, SIZE(data) = ', SIZE(data)
+     else
+        print *, 'data of type "', trim(obstype),'"  from producer "', producer, '" is not handled'
+        stop  'ERROR: p_prep_obs'
+     endif
+
+
+  else
+     print *, 'unknown producer ', trim(producer), ' in "infile.data"'
+     stop 'ERROR: p_prep_obs'
+  endif
+
+  ! Read position and depth from model grid
+  !
+  call  get_mod_grid(modlon, modlat, depths, mindx, meandx, nx, ny)
+
+  if (.not. data_eq_obs) then
+     ! Compute bilinear coefficients
+     ! Extract the defined and wet data points
+     ! Write locations to ijfile to be used in TECPLOT
+     !
+     call get_def_wet_point(obs, data, gr, depths, modlat, modlon, nrobs, nx, ny)
+  else
+     call check_forland(data, depths, size(data), nx, ny)
+     nrobs = size(data)
+     allocate(obs(nrobs))
+     obs = data
+  end if
+  deallocate(data)
+
+  if (trim(obstype) == 'TSLA') then
+     call set_re_TSLA(nrobs, obs, nx, ny, modlon, modlat)
+  end if
+
+  where (obs % d + 1.0 == obs % d)
+     obs % status = .false.
+  end where
+
+  ! Superob dense 2D data
+  !
+  if (dosuperob) then
+     allocate(sobs(nrobs))
+     call superob(obstype, nrobs, obs, nx, ny, modlon, modlat, nrsobs, sobs, is3d)
+     
+     deallocate(obs)
+     allocate(obs(nrsobs))
+     obs = sobs(1 : nrsobs)
+     nrobs = nrsobs
+     deallocate(sobs)
+  end if
+
+  if (nrobs .ge. maxobs) then
+     print *, 'max No. of data reached, increase it!'
+     stop 'ERROR: p_prep_obs'
+  elseif (nrobs .le. 1) then
+     print *, 'less than one observation in the whole dataset'
+     !PS 4/9/2011 stop 'ERROR: p_prep_obs: Not worth the money'
+  end if
+
+  ! Write data to the binary file "observations.uf"
+  !
+  call write_wet_file(obs, nrobs)
+
+  call uobs_get(obs(1 : nrobs) % id, nrobs, .true.)
+  allocate(thisobs(nrobs))
+  do i = 1, nuobs
+     nthisobs = 0
+     do k = 1, nrobs
+        if (trim(unique_obs(i)) == trim(obs(k) % id)) then
+           nthisobs = nthisobs + 1
+           thisobs(nthisobs) = k
+        end if
+     end do
+
+     if (nthisobs > 0) then
+        call obs2nc(nthisobs, obs(thisobs(1 : nthisobs)))
+     end if
+  end do
+  deallocate(thisobs)
+
+  print *, 'Last observation:'
+  print '(a)','   obs       var    id      lon   lat  depth   ipiv  jpiv   nsup'//&
+         '  4-bilin-coeffs    active  orig (i,j)   dp    age orig_id'
+  print '(2g10.2,a6,3f6.1,3i6,4f5.1,l5,2i7,f7.1,2i5)', obs(nrobs)
+
+  deallocate(obs)
+  deallocate(depths)
+  deallocate(modlon)
+  deallocate(modlat)
+
+  print *, 'prep_obs: end of processing'
+end program p_prep_obs
+
+
+subroutine obs2nc(nobs, obs)
+  use mod_measurement
+  use nfw_mod
+  implicit none
+
+  integer, parameter :: STRLEN = 512
+
+  integer, intent(in) :: nobs
+  type(measurement), intent(in) :: obs(nobs)
+
+  character(STRLEN) :: fname
+  integer :: ncid, obsdimid(1), lon_id, lat_id, depth_id, d_id, var_id, age_id
+  integer :: n_id, ipiv_id, jpiv_id
+  integer :: n(nobs)
+
+  ! Create netcdf file of observations
+  !
+  write(fname, '(a, a, a)') 'observations-', trim(obs(1) % id), '.nc'
+  print *, 'dumping observations to "', trim(fname), '"'
+
+  call nfw_create(fname, nf_clobber, ncid)
+
+  call nfw_def_dim(fname, ncid, 'nobs', nobs, obsdimid(1))
+  call nfw_def_var(fname, ncid, 'lon', nf_float, 1, obsdimid(1), lon_id)
+  call nfw_def_var(fname, ncid,  'lat', nf_float, 1, obsdimid(1), lat_id)
+  call nfw_def_var(fname, ncid, 'depth', nf_float, 1, obsdimid(1), depth_id)
+  call nfw_def_var(fname, ncid, 'd', nf_float, 1, obsdimid(1), d_id)
+  call nfw_def_var(fname, ncid, 'var', nf_float, 1, obsdimid(1), var_id)
+  call nfw_def_var(fname, ncid, 'age', nf_int, 1, obsdimid(1), age_id)
+  call nfw_def_var(fname, ncid, 'n', nf_int, 1, obsdimid(1), n_id)
+  call nfw_def_var(fname, ncid, 'ipiv', nf_int, 1, obsdimid(1), ipiv_id)
+  call nfw_def_var(fname, ncid, 'jpiv', nf_int, 1, obsdimid(1), jpiv_id)
+  call nfw_enddef(fname, ncid)
+
+  call nfw_put_var_double(fname, ncid, lon_id, obs(1:nobs) % lon)
+  call nfw_put_var_double(fname, ncid, lat_id, obs(1:nobs) % lat)
+  call nfw_put_var_double(fname, ncid, depth_id, obs(1:nobs) % depth)
+  call nfw_put_var_double(fname, ncid, d_id, obs(1:nobs) % d)
+  call nfw_put_var_double(fname, ncid, var_id, obs(1:nobs) % var)
+  call nfw_put_var_int(fname, ncid, age_id, obs(1:nobs) % date)
+  call nfw_put_var_int(fname, ncid, ipiv_id, obs(1:nobs) % ipiv)
+  call nfw_put_var_int(fname, ncid, jpiv_id, obs(1:nobs) % jpiv)
+  n = int(obs(1:nobs) % h)
+  call nfw_put_var_int(fname, ncid, n_id, n)
+  
+  call nfw_close(fname, ncid)
+end subroutine obs2nc
+
+
+subroutine check_forland(data, depths, nrobs, ni, nj)
+  use mod_measurement
+
+  type (measurement), intent(inout), dimension(nrobs) :: data
+  real, dimension(ni, nj), intent(in)  ::  depths
+  integer, intent(in) :: nrobs
+  integer, intent(in) :: ni, nj
+
+  integer :: o, imin, jmin, imax, jmax, nmasked
+
+  nmasked = 0
+  do o = 1, nrobs
+     imin = max(1, data(o) % ipiv - 1)
+     jmin = max(1, data(o) % jpiv - 1)
+     imax = min(ni, data(o) % ipiv + 2)
+     jmax = min(nj, data(o) % jpiv + 2)
+     if (any(depths(imin:imax,jmin:jmax) < 10.0 .or. depths(imin:imax,jmin:jmax) == depths(imin:imax,jmin:jmax) + 1.0)) then
+        data(o) % status = .false.
+        nmasked = nmasked + 1
+     end if
+  end do
+  print *, "  check_forland(): ", nmasked, "obs close to land masked" 
+end subroutine check_forland

EnKF-MPI-TOPAZ/Prep_Routines/superobs.c

@@ -0,0 +1,73 @@
+/* File:          superobs.c
+ *
+ * Created:       2 Sep 2008
+ *
+ * Last modified: 2 Sep 2008
+ * Author:        Pavel Sakov
+ *                NERSC
+ *
+ * Purpose:       Sorting of observations according to model grid cells.
+ *
+ * Description:   Given array of pivot indices for each observation, sort them
+ *                in such a way that observations within each model grid cell
+ *                will cluster together.
+ *
+ * Modifications: none
+ */
+
+#include <math.h>
+#include "cfortran.h"
+
+#define IMAX 4096
+#define JMAX 4096
+
+typedef struct {
+    int i;
+    int j;
+    int index;
+} indexedvalue;
+
+static int comp(const void* p1, const void* p2)
+{
+    indexedvalue* v1 = (indexedvalue*) p1;
+    indexedvalue* v2 = (indexedvalue*) p2;
+
+    if (v1->i > v2->i)
+	return 1;
+    else if (v1->i < v2->i)
+	return -1;
+    else if (v1->j > v2->j)
+	return 1;
+    else if (v1->j < v2->j)
+	return -1;
+    return 0;
+}
+
+void sortgriddedobs(double pn, int ipiv[], int jpiv[], int sorted[])
+{
+    int n = (int) pn;
+    indexedvalue* iv = malloc(n * sizeof(indexedvalue));
+    int i;
+
+    for (i = 0; i < n; ++i) {
+	int ii = ipiv[i];
+	int jj = jpiv[i];
+
+	if (ii <= 0 || ii > IMAX || jj <= 0 || jj > JMAX) {
+	    fprintf(stderr, "ERROR: superobs.c: sortgriddedobs(): ipiv(%d) = %d or jpiv(%d) = %d out of bounds\n", i, ii, i, jj);
+	    exit(1);
+	}
+	iv[i].i = ii;
+	iv[i].j = jj;
+	iv[i].index = i;
+    }
+    
+    qsort(iv, n, sizeof(indexedvalue), comp);
+
+    for (i = 0; i < n; ++i)
+	sorted[i] = iv[i].index + 1;
+
+    free(iv);
+}
+
+FCALLSCSUB4(sortgriddedobs, SORTGRIDDEDOBS, sortgriddedobs, DOUBLE, PINT, PINT, PINT)

EnKF-MPI-TOPAZ/Prep_Routines/superobs3d.c

@@ -0,0 +1,79 @@
+/* File:          superobs3.c
+ *
+ * Created:       17 Nov 2009
+ *
+ * Last modified: 17 Nov 2009
+ * Author:        Pavel Sakov
+ *                NERSC
+ *
+ * Purpose:       Sorting of observations according to model grid cells.
+ *
+ * Description:   This file is an extension of the superobs.c for the 3D case.
+ *
+ * Modifications: none
+ */
+
+#include <math.h>
+#include "cfortran.h"
+
+#define IMAX 4096
+#define JMAX 4096
+#define KMAX 150
+
+typedef struct {
+    int i;
+    int j;
+    int k;
+    int index;
+} indexedvalue;
+
+static int comp(const void* p1, const void* p2)
+{
+    indexedvalue* v1 = (indexedvalue*) p1;
+    indexedvalue* v2 = (indexedvalue*) p2;
+
+    if (v1->i > v2->i)
+	return 1;
+    else if (v1->i < v2->i)
+	return -1;
+    else if (v1->j > v2->j)
+	return 1;
+    else if (v1->j < v2->j)
+	return -1;
+    else if (v1->k > v2->k)
+	return 1;
+    else if (v1->k < v2->k)
+	return -1;
+    return 0;
+}
+
+void sortgriddedobs3d(double pn, int ipiv[], int jpiv[], int kpiv[], int sorted[])
+{
+    int n = (int) pn;
+    indexedvalue* iv = malloc(n * sizeof(indexedvalue));
+    int i;
+
+    for (i = 0; i < n; ++i) {
+	int ii = ipiv[i];
+	int jj = jpiv[i];
+	int kk = kpiv[i];
+
+	if (ii <= 0 || ii > IMAX || jj <= 0 || jj > JMAX || kk < 0 || kk > KMAX) {
+	    fprintf(stderr, "ERROR: superobs.c: sortgriddedobs(): ipiv(%d) = %d or jpiv(%d) = %d or kpiv(%d) = %d out of bounds\n", i, ii, i, jj, i, kk);
+	    exit(1);
+	}
+	iv[i].i = ii;
+	iv[i].j = jj;
+	iv[i].k = kk;
+	iv[i].index = i;
+    }
+    
+    qsort(iv, n, sizeof(indexedvalue), comp);
+
+    for (i = 0; i < n; ++i)
+	sorted[i] = iv[i].index + 1;
+
+    free(iv);
+}
+
+FCALLSCSUB5(sortgriddedobs3d, SORTGRIDDEDOBS3D, sortgriddedobs3d, DOUBLE, PINT, PINT, PINT, PINT)

EnKF-MPI-TOPAZ/README.txt

@@ -0,0 +1,3 @@
+- To compile, the configuration make.mn3 has to be chosen
+
+MAKE SURE TO first source enkf_modules_to_load.txt

EnKF-MPI-TOPAZ/Tools/EnKF_assemble.sh

@@ -0,0 +1,51 @@
+#!/bin/bash
+usage="####################################################################\n\
+This routine collects the analysed fields from the EnKF, and assembles \n\
+them into files of name analysisXXX.[ab] analysisICE.uf - these files can be \n\
+used as restart files by HYCOM. The unassembled fields have names of type\n\
+analysisXXX_procXX.[ab] \n\n\
+Usage:   $(basename $0)  restart_template ice_template ensemble_member nproc \n\
+Where: \n\
+\t\"restart_template\" is an already working restart file  \n\
+\t\"ice_template\"     is an already working ice restart file  \n\
+\t\"ensemble member\"  is the ensemble member number of this restart file \n\
+\t\"nproc\"            is the number of MPI threads used when running the EnKF  \n\
+\n\
+Example:\n\
+\t EnKF_assemble.sh Forecast/ENSrestart2007_289_00.a Forecast/ENSrestart2007_289_00ICE.uf  3 4
+\n\n\
+NB:\n\
+Note that the templates are needed to \"fill in\" what hasn't been updated by the \n\
+EnKF in the final analysis file. \n\
+####################################################################\n"
+
+
+prog="$(dirname $0)/EnKF_assemble"
+
+
+[ $# -ne 4 ] && { echo -e $usage ; exit 1 ; }
+
+# Run EnKF postprocess -- This processes the analysis files,
+# puts the files a final analyzed file, having the correct
+# order of the restart fields
+$prog $@
+[ $? -ne 0 ]  && { echo EnKF_assemble failed ; exit 1 ; }
+
+restartbase=$(echo $1 | sed "s/\.[ab]$//")
+
+# The above only reorders the analysis fields into correct order, but
+# the ".b" file will lack a header. This copies the header from the
+# template file
+
+cmem=$(echo 00$3 | tail -c4)
+ppfile=analysis$cmem
+
+myrandom="$RANDOM_$RANDOM"
+head -n2 ${restartbase}.b > tmp$myrandom.b
+cat ${ppfile}.b >> tmp$myrandom.b
+mv tmp$myrandom.b ${ppfile}.b
+
+
+# We should now have a analysis file named "analysisXXX.[ab]" and analysisICE.uf
+
+echo $?

EnKF-MPI-TOPAZ/Tools/MODEL.CPP

@@ -0,0 +1,3 @@
+#define ICE
+#define TOPAZ 
+#define SINGLE_RESTART

EnKF-MPI-TOPAZ/Tools/m_fixhycom_eco_metno.F90

@@ -0,0 +1,424 @@
+module m_fixhycom_eco_metno
+!Ehouarn: March 2011
+!fixanalysis: remapping of tracers after physical analysis!
+!use of remapping subroutines embedded in hycom to interpolate!
+!biogeochemical tracer on the analysis grid (dp)!
+!Remapping is realized after correction of negative anlaysis dp!
+
+contains
+      subroutine hybgen_weno_coefs(s,dp,lc,ci,kk,ks,thin)
+      implicit none
+
+      integer kk,ks
+      logical lc(kk)
+      real    s(kk,ks),dp(kk),ci(kk,ks,2),thin
+!
+!-----------------------------------------------------------------------
+!  1) coefficents for remaping from one set of vertical cells to another.
+!     method: monotonic WENO-like alternative to PPM across each input cell
+!             a second order polynomial approximation of the profiles
+!             using a WENO reconciliation of the slopes to compute the 
+!             interfacial values 
+!
+!     REFERENCE?
+!
+!  2) input arguments:
+!       s     - initial scalar fields in pi-layer space
+!       dp    - initial layer thicknesses (>=thin)
+!       lc    - use PCM for selected layers
+!       kk    - number of layers
+!       ks    - number of fields
+!       thin  - layer thickness (>0) that can be ignored
+!
+!  3) output arguments:
+!       ci    - coefficents for hybgen_weno_remap
+!                ci.1 is value at interface above
+!                ci.2 is value at interface below
+!
+!  4) Laurent Debreu, Grenoble.
+!     Alan J. Wallcraft,  Naval Research Laboratory,  July 2008.
+!-----------------------------------------------------------------------
+!
+      real, parameter :: dsmll=1.0e-8
+!
+      integer j,i
+      real    q,q01,q02,q001,q002
+      real    qdpjm(kk),qdpjmjp(kk),dpjm2jp(kk)
+      real    zw(kk+1,3)
+
+      !compute grid metrics
+      do j=2,kk-1
+        qdpjm(  j) = 1.0/(dp(j-1) +     dp(j))
+        qdpjmjp(j) = 1.0/(dp(j-1) +     dp(j) + dp(j+1))
+        dpjm2jp(j) =      dp(j-1) + 2.0*dp(j) + dp(j+1)
+      enddo !j
+      j=kk
+        qdpjm(  j) = 1.0/(dp(j-1) +     dp(j))
+!
+      do i= 1,ks
+        do j=2,kk
+          zw(j,3) = qdpjm(j)*(s(j,i)-s(j-1,i))
+        enddo !j
+          j = 1  !PCM first layer
+            ci(j,i,1) = s(j,i)
+            ci(j,i,2) = s(j,i)
+            zw(j,  1) = 0.0
+            zw(j,  2) = 0.0
+        do j=2,kk-1
+          if     (lc(j) .or. dp(j).le.thin) then  !use PCM
+            ci(j,i,1) = s(j,i)
+            ci(j,i,2) = s(j,i)
+            zw(j,  1) = 0.0
+            zw(j,  2) = 0.0
+          else
+            q001 = dp(j)*zw(j+1,3)
+            q002 = dp(j)*zw(j,  3)
+            if (q001*q002 < 0.0) then
+              q001 = 0.0
+              q002 = 0.0
+            endif
+            q01 = dpjm2jp(j)*zw(j+1,3)
+            q02 = dpjm2jp(j)*zw(j,  3)
+            if     (abs(q001) > abs(q02)) then
+              q001 = q02
+            endif
+            if     (abs(q002) > abs(q01)) then
+              q002 = q01
+            endif
+            q    = (q001-q002)*qdpjmjp(j)
+            q001 = q001-q*dp(j+1)
+            q002 = q002+q*dp(j-1)
+
+            ci(j,i,2) = s(j,i)+q001
+            ci(j,i,1) = s(j,i)-q002
+            zw(  j,1) = (2.0*q001-q002)**2
+            zw(  j,2) = (2.0*q002-q001)**2
+          endif  !PCM:WEND
+        enddo !j
+          j = kk  !PCM last layer
+            ci(j,i,1) = s(j,i)
+            ci(j,i,2) = s(j,i)
+            zw(j,  1) = 0.0
+            zw(j,  2) = 0.0
+
+        do j=2,kk
+          q002 = max(zw(j-1,2),dsmll)
+          q001 = max(zw(j,  1),dsmll)
+          zw(j,3) = (q001*ci(j-1,i,2)+q002*ci(j,i,1))/(q001+q002)
+        enddo !j
+          zw(   1,3) = 2.0*s( 1,i)-zw( 2,3)  !not used?
+          zw(kk+1,3) = 2.0*s(kk,i)-zw(kk,3)  !not used?
+
+        do j=2,kk-1
+          if     (.not.(lc(j) .or. dp(j).le.thin)) then  !don't use PCM
+            q01  = zw(j+1,3)-s(j,i)
+            q02  = s(j,i)-zw(j,3)
+            q001 = 2.0*q01
+            q002 = 2.0*q02
+            if     (q01*q02 < 0.0) then
+              q01 = 0.0
+              q02 = 0.0
+            elseif (abs(q01) > abs(q002)) then
+              q01 = q002
+            elseif (abs(q02) > abs(q001)) then
+              q02 = q001
+            endif
+            ci(j,i,1) = s(j,i)-q02
+            ci(j,i,2) = s(j,i)+q01
+          endif  !PCM:WEND
+        enddo !j
+      enddo !i
+      return
+      end subroutine hybgen_weno_coefs
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      subroutine hybgen_weno_remap(si,pi,dpi,ci,&
+                                  so,po,ki,ko,ks,thin)
+      implicit none
+!
+      integer ki,ko,ks
+      real    si(ki,ks),pi(ki+1),dpi(ki),ci(ki,ks,2),&
+             so(ko,ks),po(ko+1),thin
+!
+!-----------------------------------------------------------------------
+!  1) remap from one set of vertical cells to another.
+!     method: monotonic WENO-like alternative to PPM across each input cell
+!             a second order polynomial approximation of the profiles
+!             using a WENO reconciliation of the slopes to compute the 
+!             interfacial values 
+!             the output is the average of the interpolation
+!             profile across each output cell.
+!
+!     REFERENCE?
+!
+!  2) input arguments:
+!       si    - initial scalar fields in pi-layer space
+!       pi    - initial layer interface depths (non-negative)
+!                  pi(   1) is the surface
+!                  pi(ki+1) is the bathymetry
+!                  pi(k+1) >= pi(k)
+!       dpi   - initial layer thicknesses (dpi(k)=pi(k+1)-pi(k))
+!       ci    - coefficents from hybgen_weno_coefs
+!                ci.1 is value at interface above
+!                ci.2 is value at interface below
+!       ki    - number of  input layers
+!       ko    - number of output layers
+!       ks    - number of fields
+!       po    - target interface depths (non-negative)
+!                  po(   1) is the surface
+!                  po(ko+1) is the bathymetry (== pi(ki+1))
+!                  po(k+1) >= po(k)
+!       thin  - layer thickness (>0) that can be ignored
+!
+!  3) output arguments:
+!       so    - scalar fields in po-layer space
+!
+!  4) Laurent Debreu, Grenoble.
+!     Alan J. Wallcraft,  Naval Research Laboratory,  Aug. 2007.
+!-----------------------------------------------------------------------
+!
+      integer i,k,l,lb,lt
+      real    dpb,dpt,qb0,qb1,qb2,qt0,qt1,qt2,xb,xt,zb,zt,zx,o
+      real*8  sz
+!
+      zx=pi(ki+1) !maximum depth
+      zb=max(po(1),pi(1))
+      lb=1
+      do while (pi(lb+1).lt.zb .and. lb.lt.ki)
+        lb=lb+1
+      enddo
+      do k= 1,ko  !output layers
+        zt = zb
+        zb = min(po(k+1),zx)
+!       write(lp,*) 'k,zt,zb = ',k,zt,zb
+        lt=lb !top will always correspond to bottom of previous
+              !find input layer containing bottom output interface
+        do while (pi(lb+1).lt.zb .and. lb.lt.ki)
+          lb=lb+1
+        enddo
+        if     (zb-zt.le.thin .or. zt.ge.zx) then
+          if     (k.ne.1) then
+!
+! ---       thin or bottomed layer, values taken from layer above
+!
+            do i= 1,ks
+              so(k,i) = so(k-1,i)
+            enddo !i
+          else !thin surface layer
+            do i= 1,ks
+              so(k,i) = si(k,i)
+            enddo !i
+          endif
+        else
+
+!         form layer averages.
+!
+!         if     (pi(lb).gt.zt) then
+!           write(lp,*) 'bad lb = ',lb
+!           stop
+!         endif
+          xt=(zt-pi(lt))/max(dpi(lt),thin)
+          xb=(zb-pi(lb))/max(dpi(lb),thin)
+          if     (lt.ne.lb) then  !multiple layers
+            dpt = pi(lt+1)-zt
+            dpb = zb-pi(lb)
+            qt1 = xt*(xt-1.0)
+            qt2 = qt1+xt
+            qt0 = 1.0-qt1-qt2
+            qb1 = (xb-1.0)**2
+            qb2 = qb1-1.0+xb
+            qb0 = 1.0-qb1-qb2
+            do i= 1,ks
+              o = si((lt+lb)/2,i)  !offset to reduce round-off
+              sz = dpt*(qt0*(si(lt,i)  -o) + &
+                       qt1*(ci(lt,i,1)-o) + &
+                       qt2*(ci(lt,i,2)-o)  )
+              do l=lt+1,lb-1
+                sz = sz+dpi(l)*(si(l,i) - o)
+              enddo !l
+              sz  = sz + dpb*(qb0*(si(lb,i)  -o) + &
+                             qb1*(ci(lb,i,1)-o) + &
+                             qb2*(ci(lb,i,2)-o)  )
+              so(k,i) = o + sz/(zb-zt)  !zb-zt>=thin
+            enddo !i
+          else !single layer
+            qt1 = xb**2 + xt**2 + xb*xt + 1.0 - 2.0*(xb+xt)
+            qt2 = qt1 - 1.0 + (xb+xt)
+            qt0 = 1.0 - qt1 - qt2
+            do i= 1,ks
+              sz=qt0*(si(lt,i)  -o) + &
+                qt1*(ci(lt,i,1)-o) + &
+                qt2*(ci(lt,i,2)-o) 
+              so(k,i) = o + sz
+            enddo !i
+          endif !layers
+        endif !thin:std layer
+      enddo !k
+      return
+      end subroutine hybgen_weno_remap
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
+
+      integer function tracr_get_incr(char2) 
+      !function returns the number of the tracer.
+      !char => integer
+      implicit none        
+      character(len=2) :: char2
+      
+      tracr_get_incr=-1
+      select case (char2)
+         case ('01')
+           tracr_get_incr=1
+	 case ('02')
+           tracr_get_incr=2
+	 case ('03')
+           tracr_get_incr=3
+	 case ('04')
+           tracr_get_incr=4
+	 case ('05')
+           tracr_get_incr=5
+	 case ('06')
+           tracr_get_incr=6
+	 case ('07')
+           tracr_get_incr=7
+	 case ('08')
+           tracr_get_incr=8
+	 case ('09')
+           tracr_get_incr=9 
+	 case ('10')
+           tracr_get_incr=10
+	 case ('11')
+           tracr_get_incr=11
+	 case default
+           print *,'tracer unknown',char2
+      end select
+      return
+      
+      end function
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
+      integer function compute_kisop(temp,sal,nz) 
+      !function defines which layers are isopycnal 
+      implicit none             
+      integer::nz
+      real,dimension(1:nz)::temp,sal
+      real::eps,tmp
+      integer::k
+      
+      eps=0.1
+      
+      do k=2,nz-1
+        if (sig(temp(k),sal(k))-sig_ref(k).lt.0.)then
+	  tmp=(sig(temp(k),sal(k))-sig_ref(k))/(sig_ref(k)-sig_ref(k-1))
+	  if (tmp.gt.eps)then
+	    compute_kisop=k
+	    return
+	  else
+	    tmp=(sig(temp(k),sal(k))-sig_ref(k))/(sig_ref(k+1)-sig_ref(k))
+	    if(tmp.gt.eps)then
+	     compute_kisop=k
+	     return
+	    endif 
+	  endif
+	endif
+      enddo
+      compute_kisop=nz
+      return
+      
+      end function
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1    
+      
+      real function sig(t,s)
+      !function returns the value of sigma_0
+      !according to T and S
+      implicit none
+      real::t,s
+      real :: c1,c2,c3,c4,c5,c6,c7
+        
+      c1=-1.36471E-01  
+      c2= 4.68181E-02  
+      c3= 8.07004E-01  
+      c4=-7.45353E-03  
+      c5=-2.94418E-03  
+      c6= 3.43570E-05  
+      c7= 3.48658E-05  
+      
+      sig=(c1+c3*s+t*(c2+c5*s+t*(c4+c7*s+c6*t)))         
+      return	 
+      
+      end function
+ 
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
+      
+      real function sig_ref(k)
+      !function return the value of the target density for a given layer
+      implicit none
+      integer::k
+      
+      select case (k) 
+        case (1)
+	  sig_ref=0.1
+	case (2)
+	  sig_ref=0.2 
+	case (3)
+	  sig_ref=0.3 	  
+	case (4)
+	  sig_ref=0.4 	   
+ 	case (5)
+	  sig_ref=0.5 
+        case (6)
+	  sig_ref=24.05
+	case (7)
+	  sig_ref=24.96 
+	case (8)
+	  sig_ref=25.68 	  
+	case (9)
+	  sig_ref=26.05 	   
+ 	case (10)
+	  sig_ref=26.30 	  
+        case (11)
+	  sig_ref=26.60
+	case (12)
+	  sig_ref=26.83 
+	case (13)
+	  sig_ref=27.03 	  
+	case (14)
+	  sig_ref=27.20 	   
+ 	case (15)
+	  sig_ref=27.33 
+        case (16)
+	  sig_ref=27.46
+	case (17)
+	  sig_ref=27.55 
+	case (18)
+	  sig_ref=27.66 	  
+	case (19)
+	  sig_ref=27.74 	   
+ 	case (20)
+	  sig_ref=27.82 	  
+	case (21)
+	  sig_ref=27.90
+	case (22)
+	  sig_ref=27.97 
+	case (23)
+	  sig_ref=28.01 	  
+	case (24)
+	  sig_ref=28.04 	   
+ 	case (25)
+	  sig_ref=28.07 
+        case (26)
+	  sig_ref=28.09
+	case (27)
+	  sig_ref=28.11 
+	case (28)
+	  sig_ref=28.13 
+       
+      end select    
+	       
+      return	 
+      
+      end function
+ 
+end module

EnKF-MPI-TOPAZ/Tools/makefile

@@ -0,0 +1,159 @@
+MPI = NO
+include ../make.inc
+
+VPATH = ../:./:TMP
+
+PROGS = EnKF_assemble\
+checkice\
+checkice_en\
+consistency\
+fixhycom\
+fixhycom_eco\
+obsstats\
+oldtonewobs
+
+PROGS0 = consistency
+
+all: $(PROGS)
+
+ENKF_ASSEMBLE_OBJ = qmpi.o\
+mod_raw_io.o\
+m_parse_blkdat.o\
+m_put_mod_fld.o\
+p_EnKF_assemble.o
+
+CONSISTENCY_OBJ = qmpi.o\
+mod_raw_io.o\
+m_parse_blkdat.o\
+m_put_mod_fld.o\
+m_get_mod_grid.o\
+m_get_mod_fld.o\
+nfw.o\
+mod_testinfo.o\
+p_consistency.o
+
+CHECK_ICE_OBJ = qmpi.o\
+mod_raw_io.o\
+m_parse_blkdat.o\
+m_get_mod_grid.o\
+p_check_ice.o
+
+CHECK_ICE_OBJ_EN = qmpi.o\
+mod_raw_io.o\
+m_parse_blkdat.o\
+m_get_mod_grid.o\
+m_get_mod_fld.o\
+p_check_ice_en.o
+
+
+FIXHYCOM_OBJ = qmpi.o\
+m_random.o\
+mod_raw_io.o\
+m_parse_blkdat.o\
+m_put_mod_fld.o\
+m_get_mod_grid.o\
+m_get_mod_fld.o\
+p_fixhycom.o
+
+FIXHYCOM_ECO_OBJ = qmpi.o\
+m_fixhycom_eco_metno.o\
+mod_raw_io.o\
+m_parse_blkdat.o\
+m_put_mod_fld.o\
+m_get_mod_grid.o\
+m_get_mod_fld.o\
+distribute.o\
+p_fixhycom_eco.o
+
+OBSSTATS_SRC_C = order.c
+
+OBSSTATS_SRC_F90 = qmpi.F90\
+m_parameters.F90\
+mod_measurement.F90\
+mod_raw_io.F90\
+m_parse_blkdat.F90\
+m_put_mod_fld.F90\
+m_get_mod_grid.F90\
+m_spherdist.F90\
+m_Generate_element_Si.F90\
+m_get_mod_nrens.F90\
+m_insitu.F90\
+m_obs.F90\
+m_set_random_seed2.F90\
+mod_sphere_tools.F90\
+m_get_mod_fld.F90\
+m_random.F90\
+m_prep_4_EnKF.F90\
+m_uobs.F90\
+nfw.F90\
+p_obsstats.F90
+
+TESTX4_SRC_F90 = qmpi.F90\
+m_parse_blkdat.F90\
+m_get_mod_nrens.F90\
+testX4.F90
+
+OBSSTATS_OBJ = $(OBSSTATS_SRC_C:.c=.o) $(OBSSTATS_SRC_F77:.F=.o) $(OBSSTATS_SRC_F90:.F90=.o)
+
+OLDTONEWOBS_OBJ = mod_measurement_oldnew.o\
+p_oldtonewobs.o
+
+TESTX4_OBJ = $(TESTX4_SRC_F90:.F90=.o)
+
+m_Generate_element_Si.o: m_parse_blkdat.o mod_measurement.o m_get_mod_fld.o m_insitu.o m_obs.o
+m_insitu.o: nfw.o
+m_get_mod_nrens.o: qmpi.o
+m_obs.o : m_parameters.o m_uobs.o
+
+$(ENKF_ASSEMBLE_OBJ) $(CONSISTENCY_OBJ) $(FIXHYCOM_ECO_OBJ) $(FIXHYCOM_OBJ) $(OBSSTATS_OBJ) $(OLDTONEWOBS_OBJ): MODEL.CPP makefile
+
+EnKF_assemble: $(ENKF_ASSEMBLE_OBJ)
+	@echo "->EnKF_assemble"
+	@cd ./TMP ; $(LD) $(LINKFLAGS) -o ../EnKF_assemble $(ENKF_ASSEMBLE_OBJ) 
+
+consistency: $(CONSISTENCY_OBJ)
+	@echo "->consistency"
+	@cd ./TMP ; $(LD) $(LINKFLAGS) -o ../consistency $(CONSISTENCY_OBJ) $(LIBS)
+
+checkice: $(CHECK_ICE_OBJ)
+	   @echo "->checkice"
+	   @cd ./TMP ; $(LD) $(LINKFLAGS) -o ../checkice $(CHECK_ICE_OBJ) $(LIBS)
+
+checkice_en: $(CHECK_ICE_OBJ_EN)
+	   @echo "->checkice_en"
+	   @cd ./TMP ; $(LD) $(LINKFLAGS) -o ../checkice_en $(CHECK_ICE_OBJ_EN) $(LIBS)
+
+fixhycom: $(FIXHYCOM_OBJ)
+	@echo "->fixhycom"
+	@cd ./TMP ; $(LD) $(LINKFLAGS) -o ../fixhycom $(FIXHYCOM_OBJ)
+
+fixhycom_eco: $(FIXHYCOM_ECO_OBJ)
+	@echo "->fixhycom_eco"
+	@cd ./TMP ; $(LD) $(LINKFLAGS) -o ../fixhycom_eco $(FIXHYCOM_ECO_OBJ)
+
+obsstats: $(OBSSTATS_OBJ)
+	@echo "->obsstats"
+	@cd ./TMP ; $(LD) $(LINKFLAGS) -o ../obsstats $(OBSSTATS_OBJ) $(LIBS)  $(MATLIBS)
+
+oldtonewobs: $(OLDTONEWOBS_OBJ)  
+	@echo "->oldtonewobs"
+	@cd ./TMP ; $(LD) $(LINKFLAGS) -o ../oldtonewobs $(OLDTONEWOBS_OBJ) 
+
+clean:
+	@rm -f *.o *.mod TMP/*.* $(PROGS)
+
+%.o: %.F90
+	@echo "  $*".F90
+	@rm -f ./TMP/$*.f90
+	@cat MODEL.CPP $< | $(CPP) $(CPPFLAGS) > ./TMP/$*.f90
+	@cd ./TMP; $(CF90) -c $(FFLAGS) $(F90FLG) -o $*.o $*.f90
+
+%.o: %.F
+	@echo "  $*".F
+	@rm -f ./TMP/$*.f
+	@cat MODEL.CPP $< | $(CPP) $(CPPFLAGS) > ./TMP/$*.f
+	@cd ./TMP; $(CF77) -c $(FFLAGS) $(F77FLG) -o $*.o $*.f 2> /dev/null
+
+%.o: %.c
+	@echo "  $*".c
+	@cd ./TMP ; $(CC) -c $(CFLAGS) -o $*.o -I../.. ../../$*.c

EnKF-MPI-TOPAZ/Tools/mod_measurement_oldnew.F90

@@ -0,0 +1,78 @@
+module mod_measurement_oldnew
+
+   
+   type measurement_old
+      real d                       ! Measurement value
+      real var                     ! Error variance of measurement
+      character(len=5) id          ! Type of measurement ('SST', 'SLA', 'COL', 'HICE', 'FICE', 'SAL', 'TEM'
+      real lon                     ! Longitude position
+      real lat                     ! Latitude position
+      real depths                  ! depths of position 
+      integer ipiv                 ! i-pivot point in grid
+      integer jpiv                 ! j-pivot point in grid
+      integer ns                   ! representativity in mod cells (meas. support)
+                                   ! ns=0 means: point measurements
+                                   ! used in m_Generate_element_Sij.F90
+      real a1                      ! bilinear coeffisients (if ni=0)
+      real a2                      ! bilinear coeffisients
+      real a3                      ! bilinear coeffisients
+      real a4                      ! bilinear coeffisients
+      logical status               ! active or not
+   end type measurement_old
+
+   
+   type measurement_new
+      real d                       ! Measurement value
+      real var                     ! Error variance of measurement
+      character(len=5) id          ! Type of measurement ('SST', 'SLA', 'COL', 'HICE', 'FICE', 'SAL', 'TEM'
+      real lon                     ! Longitude position
+      real lat                     ! Latitude position
+      real depths                  ! depths of position 
+      integer ipiv                 ! i-pivot point in grid
+      integer jpiv                 ! j-pivot point in grid
+      integer ns                   ! representativity in mod cells (meas. support)
+                                   ! ns=0 means: point measurements
+                                   ! used in m_Generate_element_Sij.F90
+      real a1                      ! bilinear coeffisients (if ni=0)
+      real a2                      ! bilinear coeffisients
+      real a3                      ! bilinear coeffisients
+      real a4                      ! bilinear coeffisients
+      logical status               ! active or not
+      integer i_orig_grid          ! KAL - ice drift needs orig grid index as well   !!! NEW
+      integer j_orig_grid          ! KAL - ice drift needs orig grid index as well   !!! NEW
+   end type measurement_new
+
+contains
+
+   subroutine oldtonew(old,new)
+   implicit none
+
+      type (measurement_old), intent(in)  :: old
+      type (measurement_new), intent(out) :: new
+
+      new%d     =old%d
+      new%var   =old%var
+      new%id    =old%id
+      new%lon   =old%lon
+      new%lat   =old%lat
+      new%depths=old%depths
+      new%ipiv  =old%ipiv
+      new%jpiv  =old%jpiv
+      new%ns    =old%ns
+      new%a1    =old%a1
+      new%a2    =old%a2
+      new%a3    =old%a3
+      new%a4    =old%a4
+      new%status=old%status
+
+      new%i_orig_grid=0
+      new%j_orig_grid=0
+
+   end subroutine
+
+
+
+
+
+end module mod_measurement_oldnew
+

EnKF-MPI-TOPAZ/Tools/mod_sphere_tools.F90

@@ -0,0 +1,342 @@
+module mod_sphere_tools
+
+contains
+  
+   ! Routine to get cartesian coordinates from geographical coordinates
+   function geo2cart(lon,lat)
+      real, parameter :: rad=1.7453292519943295E-02,deg=57.29577951308232
+      real, intent(in) :: lon,lat
+      real, dimension(3) :: geo2cart
+
+      real :: lambda
+
+      lambda=lat*rad
+      theta=lon*rad
+      geo2cart(1)=cos(lambda)*cos(theta)
+      geo2cart(2)=cos(lambda)*sin(theta)
+      geo2cart(3)=sin(lambda)
+   end function geo2cart
+
+
+   ! Routine to calculate cross product of two 3D vectors.
+   function cross_product(v1,v2)
+      implicit none
+      real, intent(in), dimension(3) :: v1,v2
+      real, dimension(3) :: cross_product
+
+      cross_product(1) = v1(2)*v2(3) - v1(3)*v2(2)
+      cross_product(2) = v1(3)*v2(1) - v1(1)*v2(3)
+      cross_product(3) = v1(1)*v2(2) - v1(2)*v2(1)
+   end function cross_product
+
+
+   ! Routine to calculate vector norm (more precise the 2-norm)
+   function norm2(vector,p)
+      implicit none
+      integer, intent(in) :: p
+      real,    intent(in) :: vector(p)
+      integer :: i
+      real    :: norm2
+
+      norm2=0.
+      do i=1,p
+         norm2 = norm2 + vector(i)**2
+      end do
+      norm2=sqrt(norm2)
+   end function norm2
+
+
+
+
+
+
+   ! Routine to calculate wether the point (plon,plat)  is in the box
+   ! defined by crnlon,crnlat. Cnrlon/crnlat must be traversed so that 
+   ! they form a convex polygon in 3D coordinates when following indices.
+   ! It should work for for all regions defined by crnlon/crnlat...
+   function inbox(crnlon,crnlat,npt,plon,plat)
+      implicit none
+      real, parameter :: rad=1.7453292519943295E-02,deg=57.29577951308232
+
+      integer, intent(in) :: npt
+      real, dimension(npt), intent(in) :: crnlon,crnlat
+      real, intent(in) :: plon,plat
+      logical :: inbox
+
+      real, dimension(npt,3) :: cvec
+      real, dimension(3)     :: pvec
+      real, dimension(3,3)   :: rvec
+      real, dimension(3)     :: nvec, nvec_prev, cprod
+      integer :: i,im1,ip1
+      logical :: lsign
+      real    :: rotsign,old_rotsign
+
+
+      ! point vector from origo
+      pvec = geo2cart(plon,plat)
+
+      !print *,crnlon
+      !print *,crnlat
+
+      ! vector to rectangle corner
+      do i=1,npt
+         cvec(i,:) = geo2cart(crnlon(i),crnlat(i))
+      end do
+
+      ! Traverse box boundaries -- Check that traversion is
+      ! consistent and that point is in box
+      lsign=.true.
+      i=1
+      old_rotsign=0.
+      do while (i<npt+1 .and. lsign)
+         
+         ip1= mod(i      ,npt)+1
+         im1= mod(i-2+npt,npt)+1
+
+
+         ! Vectors used to span planes
+         rvec(3,:) = cvec(ip1,:)
+         rvec(2,:) = cvec(i  ,:)
+         rvec(1,:) = cvec(im1,:)
+
+         ! Normal vector to two spanning planes
+         nvec      = cross_product(rvec(2,:),rvec(3,:))
+         nvec_prev = cross_product(rvec(1,:),rvec(2,:))
+
+         ! As we move to new planes, the cross product rotates in 
+         ! a certain direction
+         cprod = cross_product(nvec_prev,nvec)
+
+         ! For anticlockwise rotation, this should be positive
+         rotsign=sign(1.,dot_product(cprod,rvec(2,:)))
+
+         ! Check that box is consistently traversed
+         if (i>1 .and. rotsign * old_rotsign < 0) then
+            print *,'Grid cell not consistently traversed'
+            print *,'or polygon is not convex'
+            stop '(inbox2)'
+         end if
+         old_rotsign=rotsign
+
+         ! If this is true for all four planes, we are in grid box
+         lsign = lsign .and. (dot_product(nvec,pvec)*rotsign)>0
+         i=i+1
+
+      end do
+      inbox = lsign
+   end function inbox
+
+
+
+
+
+
+
+
+   
+   ! Routine to get angle between two vectors defined in
+   ! geographical coordinates. 
+   function secangle(lon1,lat1,lon2,lat2)
+      implicit none
+
+      real, intent(in), dimension(2) :: lon1,lat1,lon2,lat2
+      real, dimension(3) :: nx, n2, ny
+      real :: cos1, cos2
+      real :: secangle
+
+      ! Normal of the planes defined by positions and origo
+      nx = cross_product(geo2cart(lon1(1),lat1(1)),geo2cart(lon1(2),lat1(2)))
+      n2 = cross_product(geo2cart(lon2(1),lat2(1)),geo2cart(lon2(2),lat2(2)))
+
+      ! Normal to position 1 and vector 1 (x) -- forms rh system
+      ny = cross_product(geo2cart(lon1(1),lat1(1)), nx)
+      ny = ny / norm2(ny,3)
+
+      ! Angle info 1 -- cosine of angle between planes nx and n2
+      cos1 = dot_product(nx,n2)
+
+      ! Angle info 2 -- Cosine of angle between planes ny and n2
+      cos2 = dot_product(ny,n2)
+
+      ! Angle between vectors 1 and 2
+      secangle = atan2(cos1,cos2)
+
+   end function secangle
+
+
+
+         
+
+   ! Intersection routine by Mats Bentsen.
+   ! --- this routine computes the lat/lon coordinates for the intersection
+   ! --- of the two geodesic lines which connects the lat/lon pairs a1,a2
+   ! --- and b1,b2
+   logical function intersect(lat_a1,lon_a1,lat_a2,lon_a2, &
+                              lat_b1,lon_b1,lat_b2,lon_b2, &
+                              lat_i,lon_i)
+      implicit none
+
+
+      real lat_a1,lon_a1,lat_a2,lon_a2, &
+           lat_b1,lon_b1,lat_b2,lon_b2, &
+           lat_i,lon_i
+ 
+      real lambda,theta,                  &
+           x_a1,y_a1,z_a1,x_a2,y_a2,z_a2, &
+           x_b1,y_b1,z_b1,x_b2,y_b2,z_b2, &
+           x_na,y_na,z_na,x_nb,y_nb,z_nb, &
+           x_i,y_i,z_i,l_i,               &
+           x_a,y_a,z_a,x_b,y_b,z_b,l_a,l_b,l_l,a_a,a_b
+ 
+      real rad,deg
+      parameter(rad=1.7453292519943295E-02,deg=57.29577951308232)
+ 
+! --- transforming from spherical to cartesian coordinates
+      lambda=lat_a1*rad
+      theta=lon_a1*rad
+      x_a1=cos(lambda)*cos(theta)
+      y_a1=cos(lambda)*sin(theta)
+      z_a1=sin(lambda)
+ 
+      lambda=lat_a2*rad
+      theta=lon_a2*rad
+      x_a2=cos(lambda)*cos(theta)
+      y_a2=cos(lambda)*sin(theta)
+      z_a2=sin(lambda)
+ 
+      lambda=lat_b1*rad
+      theta=lon_b1*rad
+      x_b1=cos(lambda)*cos(theta)
+      y_b1=cos(lambda)*sin(theta)
+      z_b1=sin(lambda)
+ 
+      lambda=lat_b2*rad
+      theta=lon_b2*rad
+      x_b2=cos(lambda)*cos(theta)
+      y_b2=cos(lambda)*sin(theta)
+      z_b2=sin(lambda)
+ 
+      x_na=y_a1*z_a2-y_a2*z_a1
+      y_na=z_a1*x_a2-z_a2*x_a1
+      z_na=x_a1*y_a2-x_a2*y_a1
+ 
+      x_nb=y_b1*z_b2-y_b2*z_b1
+      y_nb=z_b1*x_b2-z_b2*x_b1
+      z_nb=x_b1*y_b2-x_b2*y_b1
+ 
+! --- Let a1 be the vector from the center of the sphere to the point
+! --- (lat_a1,lon_a1) on the sphere. Similar with vectors a2, b1 and b2.
+! --- Then we compute the components and length of a vector i pointing
+! --- along the intersection of the two planes spanned out by the
+! --- vectors a1, a2 and b1, b2 respectively.
+      x_i=y_na*z_nb-y_nb*z_na
+      y_i=z_na*x_nb-z_nb*x_na
+      z_i=x_na*y_nb-x_nb*y_na
+ 
+      l_i=sqrt(x_i*x_i+y_i*y_i+z_i*z_i)
+!
+! --- check if i lies between a1 and a2
+!
+      intersect=.true.
+!
+! --- first find the vector a between a1 and a2 and its angle a_a to a1
+! --- and a2
+!
+      x_a=x_a1+x_a2
+      y_a=y_a1+y_a2
+      z_a=z_a1+z_a2
+ 
+      l_a=sqrt(x_a*x_a+y_a*y_a+z_a*z_a)
+ 
+      l_l=sign(1.,l_i*l_a)*max(1.e-9,abs(l_i*l_a))
+      a_a=acos(max(-1.,min(1.,x_a1*x_a2+y_a1*y_a2+z_a1*z_a2)))*0.5
+
+
+
+! --- if the angle between i and a is greater than
+! --- a_a, then intersect=.false.
+      if (acos(max(-1.,min(1.,(x_i*x_a+y_i*y_a+z_i*z_a)/l_l))) &
+          .gt.a_a) then
+
+         ! --- - test the opposite directed intersection vector
+         x_i=-x_i
+         y_i=-y_i
+         z_i=-z_i
+  
+         if (acos(max(-1.,min(1.,(x_i*x_a+y_i*y_a+z_i*z_a)/l_l))) &
+            .gt.a_a) intersect=.false.
+      endif
+ 
+
+
+      ! do similar test for b1 and b2
+      if (intersect) then
+ 
+        x_b=x_b1+x_b2
+        y_b=y_b1+y_b2
+        z_b=z_b1+z_b2
+ 
+        l_b=sqrt(x_b*x_b+y_b*y_b+z_b*z_b)
+ 
+        l_l=sign(1.,l_i*l_b)*max(1.e-9,abs(l_i*l_b))
+        a_b=acos(max(-1.,min(1.,x_b1*x_b2+y_b1*y_b2+z_b1*z_b2)))*0.5
+ 
+        if (acos(max(-1.,min(1.,(x_i*x_b+y_i*y_b+z_i*z_b)/l_l))) &
+            .gt.a_b) intersect=.false.
+      endif
+ 
+      ! represent the intersection in lat,lon coordinates
+      lat_i=atan2(z_i,sqrt(x_i*x_i+y_i*y_i))*deg
+      lon_i=atan2(y_i,x_i)*deg
+ 
+   end function
+
+
+
+
+
+
+elemental real function spherdist(lon1,lat1,lon2,lat2)
+! --- -----------------------------------------
+! --- Computes the distance between geo. pos.
+! --- lon1,lat1 and lon2,lat2. 
+! --- INPUT is in degrees.
+! --- -----------------------------------------
+
+   implicit none
+   REAL, intent(in) :: lon1,lat1,lon2,lat2 ! Pos. in degrees
+
+   real, parameter :: invradian=0.017453292
+   real, parameter :: rearth=6371001.0     ! Radius of earth
+
+   real  rlon1,rlat1,rlon2,rlat2           ! Pos. in radians
+   real  x1,y1,z1,x2,y2,z2                 ! Cartesian position
+   real  dx,dy,dz,dr                       ! Cartesian distances
+
+
+   rlon1=lon1*invradian             !lon1 in rad
+   rlat1=(90.-lat1)*invradian       !90-lat1 in rad 
+
+   rlon2=lon2*invradian             !lon2 in rad
+   rlat2=(90.-lat2)*invradian       !90-lat2 in rad 
+
+   x1= SIN(rlat1)*COS(rlon1)        !x,y,z of pos 1.
+   y1= SIN(rlat1)*SIN(rlon1)
+   z1= COS(rlat1) 
+
+   x2= SIN(rlat2)*COS(rlon2)        !x,y,z of pos 2.
+   y2= SIN(rlat2)*SIN(rlon2)
+   z2= COS(rlat2) 
+
+   dx=x2-x1                         !distances in x, y, z 
+   dy=y2-y1
+   dz=z2-z1
+
+   dr=SQRT(dx*dx+dy*dy+dz*dz)       !distance pytagaros
+   dr=acos(x1*x2+y1*y2+z1*z2)       ! Acr length
+
+   spherdist=dr*rearth
+
+end function spherdist
+
+end module mod_sphere_tools

EnKF-MPI-TOPAZ/Tools/mod_testinfo.F90

@@ -0,0 +1,92 @@
+module mod_testinfo
+
+
+  type testinfo
+     real             :: min, max 
+     character(len=8) :: fldname
+     integer          :: toosmall, toolarge
+  end type testinfo
+
+contains
+
+
+  subroutine tests_init(tests, numtest)
+    implicit none
+    integer, intent(in) ::  numtest
+    type(testinfo) , dimension(numtest), intent(out) :: tests
+    integer             :: k
+    tests(:)%toosmall=0
+    tests(:)%toolarge=0
+    tests(:)%fldname=''
+    do k=1,numtest
+       select case (k)
+       case (1)
+          tests(k)%fldname='temp'
+          tests(k)%max    =40.
+          tests(k)%min    =-4.8
+       case (2)
+          tests(k)%fldname='saln'
+          tests(k)%max    =40.
+          tests(k)%min    =0.   
+       case (3)
+          tests(k)%fldname='dp'
+          tests(k)%max    =10000*9806.0
+          tests(k)%min    =0.0
+       case (4)
+          tests(k)%fldname='u'
+          tests(k)%max    =4
+          tests(k)%min    =-4
+       case (5)
+          tests(k)%fldname='v'
+          tests(k)%max    =4
+          tests(k)%min    =-4
+       case (6)
+          tests(k)%fldname='ubavg'
+          tests(k)%max    =2
+          tests(k)%min    =-2
+       case (7)
+          tests(k)%fldname='vbavg'
+          tests(k)%max    =2
+          tests(k)%min    =-2
+       case (8)
+#if defined (SINGLE_RESTART)
+          tests(k)%fldname='ficem'
+#else
+          tests(k)%fldname='icec'
+#endif
+          tests(k)%min    =0.0
+          tests(k)%max    =1.0
+       case (9)
+#if defined (SINGLE_RESTART)
+          tests(k)%fldname='hicem'
+#else
+          tests(k)%fldname='hice'
+#endif
+          tests(k)%min    =0.0
+          tests(k)%max    =20.0
+       case default
+          print *,'Not set up test for k=',k
+       end select
+    end do
+  end subroutine tests_init
+
+  subroutine matchtest(cfld,tests,numtest,testindex)
+    implicit none
+    integer, intent(in) :: numtest
+    character(len=*), intent(in) :: cfld
+    type(testinfo), dimension(numtest), intent(in) :: tests
+    integer, intent(out) :: testindex
+
+    integer :: i
+
+    testindex=-1
+    do i=1,numtest
+       if (trim(cfld)==trim(tests(i)%fldname)) testindex=i
+    end do
+  end subroutine matchtest
+
+
+
+
+end module mod_testinfo
+

EnKF-MPI-TOPAZ/Tools/p_EnKF_assemble.F90

@@ -0,0 +1,291 @@
+program EnKF_postprocess
+! KAL -- The new EnKF is MPI-parallelized, and each thread will dump
+! KAL -- to its own file named "analysisXXX_procXXX.[ab]
+! KAL --
+! KAL -- This routine will gather the
+! KAL -- analysis from the separate analyzed files into one complete restart file.
+! KAL -- To do this, a "template" restart file must be specified. This file
+! KAL -- copies non-existing variables in the analyzed fields from the template,
+! KAL -- and into the final analysis. The final files produced by this routine 
+! KAL -- are named "analysisXXX.[ab]".
+! KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 
+! KAL -- Input arguments:
+! KAL --     template restart file
+! KAL --     template ice restart file
+! KAL --     ensemble member
+! KAL --     number of MPI threads used in analysis
+! KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 
+! KAL --
+! KAL -- NB: This routine will not check or modify the fields. To do that, 
+! KAL --     use "consistency" (check) and "fixhycom" (fix)
+
+
+
+   use mod_raw_io
+   use m_parse_blkdat
+   use m_put_mod_fld
+   implicit none
+
+   integer*4, external :: iargc
+
+   integer imem                  ! ensemble member
+   character(len=80) :: template,icetemplate ! restart template
+
+   character(len=80) :: afile
+   integer          :: fnd, rstind, tmpindx, iafile
+   logical          :: ex, allok, nomatch
+   character(len=8) :: cfld, ctmp
+   character(len=3) :: cproc,cmem
+   integer          :: tlevel, vlevel, nproc
+   real             :: bmin, bmax, rdummy
+   integer          :: idm,jdm,kdm
+   real, allocatable:: fld(:,:)
+   real*8, allocatable, dimension(:,:) :: &
+      ficem,hicem,hsnwm,ticem,tsrfm
+   real*4, allocatable:: fldr4(:,:)
+   real*4 :: spval,amin,amax
+
+   real, allocatable, dimension(:,:)   :: dpsum
+
+   integer,parameter :: numfields=2
+   integer :: ios,ios2, reclICE,ifld
+   character(len=8) :: fieldnames(numfields)
+   integer :: fieldlevels(numfields)
+
+
+   if (iargc()==4) then
+      call getarg(1,template)
+      call getarg(2,icetemplate)
+      call getarg(3,ctmp)
+      read(ctmp,*) imem
+      write(cmem,'(i3.3)') imem
+      call getarg(4,ctmp)
+      read(ctmp,*) nproc
+   else
+      print *,'usage: EnKF_postprocess restart_template ice_template ensemble_member nproc'
+      call exit(1)
+   endif
+
+   ! Get dimensions from blkdat
+   call parse_blkdat('idm   ','integer',rdummy,idm)
+   call parse_blkdat('jdm   ','integer',rdummy,jdm)
+   call parse_blkdat('kdm   ','integer',rdummy,kdm)
+
+   if (idm>0 .and. idm < 1e4 .and. jdm>0 .and. jdm<1e4) then
+      allocate(fld  (idm,jdm))
+      allocate(fldr4(idm,jdm))
+      allocate(ficem(idm,jdm))
+      allocate(hicem(idm,jdm))
+      allocate(hsnwm(idm,jdm))
+      allocate(ticem(idm,jdm))
+      allocate(tsrfm(idm,jdm))
+      allocate(dpsum(idm,jdm))
+   else
+      print *,'fld allocate error'
+      stop '(EnKF_postprocess)'
+   end if
+
+
+   ! Remove postfix of template file
+   fnd=max(index(template,'.a'),index(template,'.b'))
+
+
+   ! Inquire for existence
+   inquire(exist=ex,file=template(1:fnd-1)//'.b')
+   if (.not.ex) then
+      write(*,*) 'Can not find '//template(1:fnd-1)//'.b'
+      stop '(EnKF_postprocess)'
+   end if
+
+   print *,template(1:fnd-1)//'.b'
+
+   ! Loop over restart file
+   dpsum=0.
+   rstind=1 ! Restart index
+   allok=.true.
+   do while ( allok)
+
+      ! Get header info from template
+      call rst_header_from_index(template(1:fnd-1)//'.b', &
+            cfld,vlevel,tlevel,rstind,bmin,bmax,.true.)
+
+      allok=tlevel/=-1 ! test to see if read was ok
+
+
+      if (allok) then 
+
+         ! Get actual field  - for now we use the READRAW routine (later on we
+         ! should switch to m_get_mod_fld
+         call READRAW(fldr4,amin,amax,idm,jdm,.false.,spval,template(1:fnd-1)//'.a',rstind)
+         fld=fldr4
+
+
+         !print *,cfld,tlevel, vlevel
+
+
+         ! From the template, we have the stuff we need, now we go looking
+         ! in the EnKF analysis files output for the correct input. Note that
+         ! all time levels are set equal in the restart. This may introduce 
+         ! imbalances, but the alternative is probably worse.
+         !
+         ! KAL -- need list of analysis files here, for now we hardcode
+         nomatch=.true.
+         do iafile=1,nproc ! List of procs used in analysis
+
+            write(cproc,'(i3.3)') iafile-1
+            
+            ! Temporary name, will change
+            afile='analysis'//cmem//'_proc'//cproc
+
+
+            ! NB - time level=1
+            ! NB2 - the files dumped in the analysis lack a header (last argument
+            ! is false)
+            if (trim(cfld)=='ficem') then
+              ctmp='icec'
+            elseif (trim(cfld)=='hicem') then
+              ctmp='hice'
+            else
+              ctmp=trim(cfld)
+            endif
+            call rst_index_from_header(trim(afile)//'.b',ctmp,vlevel,1, &
+                                          tmpindx,bmin,bmax,.false.) 
+
+            if (tmpindx/=-1) then
+               !if (tlevel/=1) print *,'--> replacing time level with 1'
+               print '(a8," -- time, layer:",2i4,"  match : record, file",i4," ",a)', cfld,tlevel, vlevel,tmpindx,trim(afile)
+               nomatch=.false.
+
+               ! Read field from analysed file 
+               call READRAW(fldr4,amin,amax,idm,jdm,.false.,spval,trim(afile)//'.a',tmpindx)
+               fld=fldr4
+
+              ! Sjekk p at vi har lest rett - samanlign max/min fr filene
+              if     (abs(amin-bmin).gt.abs(bmin)*1.e-4 .or. &
+                      abs(bmax-amax).gt.abs(bmax)*1.e-4     ) then
+                 print *,'Inconsistency between .a and .b files'
+                 print *,'.a : ',amin,amax
+                 print *,'.b : ',bmin,bmax
+                 print *,cfld,vlevel,tlevel
+                 call exit(1)
+              end if
+
+
+
+               ! put into final, processed file -- imem is not used, actually
+               call put_mod_fld('analysis'//cmem,fld,imem,cfld,vlevel,tlevel,rstind,idm,jdm)
+               
+
+               exit
+            end if
+         end do
+
+
+         if (nomatch) then
+            print '(a8," -- time, layer:",2i4," - no match - replace with template")',cfld,tlevel,vlevel
+
+            ! put template values into final, processed file -- imem is not used, actually
+            call put_mod_fld('analysis'//cmem,fld,imem,cfld,vlevel,tlevel,rstind,idm,jdm)
+         end if
+            
+         rstind=rstind+1
+      end if ! read of template was ok
+   end do
+
+#if ! defined (SINGLE_RESTART)
+
+   ! ice processing Loop over restart file
+   print *
+   print *
+   print *,'processing ice restart file'
+   rstind=1 ! Restart index
+   allok=.true.
+
+   ! Temporary solution
+   fieldnames(1)='icec'
+   fieldnames(2)='hice'
+   vlevel=0
+
+   ! Copy template record imem to analysysICE.uf
+   inquire(iolength=reclICE)ficem,hicem,hsnwm,ticem,tsrfm
+   open(10,file=trim(icetemplate),form='unformatted',access='direct',recl=reclICE,status='old')
+   read(10,rec=imem,iostat=ios)ficem,hicem,hsnwm,ticem,tsrfm
+   close(10)
+
+   open(11,file='analysisICE.uf',form='unformatted',access='direct',recl=reclICE,status='unknown')
+   write(11,rec=imem,iostat=ios2)ficem,hicem,hsnwm,ticem,tsrfm
+   close(11)
+
+   do ifld=1,numfields
+      cfld=  fieldnames (ifld)
+      if (trim(cfld)=='icec' .or. trim(cfld)=='hice') then
+         nomatch=.true.
+         do iafile=1,nproc ! List of procs used in analysis
+            write(cproc,'(i3.3)') iafile-1
+
+            ! NB - time level=1
+            ! NB2 - the files dumped in the analysis lack a header (last argument
+            ! is false)
+            call rst_index_from_header(trim(afile)//'.b',cfld,vlevel,1, &
+                                             tmpindx,bmin,bmax,.false.) 
+
+
+            if (tmpindx/=-1) then
+               print '(a8," -- layer:",i4,"  match : record, file",i4," ",a)', cfld, vlevel,tmpindx,trim(afile)
+               nomatch=.false.
+
+               !print *,'Got match for '//cfld
+
+               ! Read field from analysed file 
+               call READRAW(fldr4,amin,amax,idm,jdm,.false.,spval,trim(afile)//'.a',tmpindx)
+               fld=fldr4
+
+              ! Sjekk p at vi har lest rett - samanlign max/min fr filene
+              if     (abs(amin-bmin).gt.abs(bmin)*1.e-4 .or. &
+                      abs(bmax-amax).gt.abs(bmax)*1.e-4     ) then
+                 print *,'Inconsistency between .a and .b files'
+                 print *,'.a : ',amin,amax
+                 print *,'.b : ',bmin,bmax
+                 print *,cfld,vlevel,tlevel
+                 call exit(1)
+              end if
+              exit
+
+            end if
+
+         end do
+
+
+         ! Check if we got ice concentration or ice thickness
+         if (.not.nomatch) then
+
+
+            inquire(iolength=reclICE)ficem,hicem,hsnwm,ticem,tsrfm  !,iceU,iceV
+            open(11,file='analysisICE.uf',form='unformatted',access='direct',recl=reclICE,status='unknown')
+            if (trim(cfld)=='icec') ficem=fld
+            if (trim(cfld)=='hice') hicem=fld
+            write(11,rec=imem,iostat=ios2)ficem,hicem,hsnwm,ticem,tsrfm !,iceU,iceV
+            close(11)
+
+            if (ios/=0 .or.ios2/=0) then
+               print *,ios
+               print *,ios2
+               print *,'Error when writing to ice ens file'
+               call exit(1)
+            end if
+         end if
+      end if
+   end do
+#endif
+
+   print *,'Normal exit of EnKF_postprocess'
+   print *,'TODO: Process dp inconsistencies'
+#if defined(AIX)
+   call exit_(0)
+#else
+   call exit(0)
+#endif
+
+
+
+end program

EnKF-MPI-TOPAZ/Tools/p_check_ice.F90

@@ -0,0 +1,124 @@
+!Fanf A short program to ensure that all member have the ice present.
+!
+! PS: if there are corrupted ic fields - then
+!       (i) the member IDs of these fields will be wrtten to the file
+!           "missing_icerecords.txt"
+!       (ii) this also will be reported to stdout
+!       (iii) and also will be reflected in icevolume.txt
+
+program checkice
+  use mod_raw_io
+  use m_parse_blkdat
+  use m_get_mod_grid
+  implicit none
+  integer*4, external :: iargc
+  integer iens
+  real, dimension(:,:), allocatable :: modlon,modlat,depths
+  logical, allocatable, dimension(:, :) :: iswater
+  integer :: idm,jdm,kdm
+  integer :: ios
+  integer ::  nens
+  real*8, allocatable, dimension(:,:) :: ficem,hicem,hsnwm,ticem,tsrfm
+  integer :: reclICE
+  real :: mindx,meandx,rdummy
+  character(len=80) :: icerestart 
+  character(len=3) :: ctmp
+  integer :: nmissing
+  real, allocatable, dimension(:) :: icevolume, icearea
+  real :: meanicevolume, maxvalue_hicem, maxvalue_ticem, maxvalue_tsrfm
+
+  if ( iargc()==2 ) then
+     call getarg(1,icerestart)
+     call getarg(2,ctmp)
+     read(ctmp,*) nens
+  else
+     print *,'"check_ice" -- A routine to check that no ice records are missing'
+     print *
+     print *,'Usage: checkice <ice_file> <ensemble_size>'
+     call exit(1)
+  endif
+
+  open(20, file = trim(icerestart), iostat = ios)
+  if (ios /= 0) then
+     print *, 'ERROR: "', trim(icerestart), '" not found'
+     call exit(1)
+  end if
+  close(20)
+
+  allocate(icevolume(nens))
+  allocate(icearea(nens))
+  icevolume = 0.0d0
+  icearea = 0.0d0
+
+  !Get model dimensions
+  call parse_blkdat('idm   ','integer',rdummy,idm)
+  call parse_blkdat('jdm   ','integer',rdummy,jdm)
+
+  allocate(modlon (idm,jdm))
+  allocate(modlat (idm,jdm))
+  allocate(depths (idm,jdm))
+  
+  call get_mod_grid(modlon, modlat, depths, mindx, meandx, idm, jdm)
+
+  allocate(iswater(idm, jdm))
+  iswater = depths > 1.0d0 .and. depths < 1.0e25
+
+  allocate(ficem(idm,jdm))
+  allocate(hicem(idm,jdm))
+  allocate(hsnwm(idm,jdm))
+  allocate(ticem(idm,jdm))
+  allocate(tsrfm(idm,jdm))
+  inquire(iolength = reclICE) ficem, hicem, hsnwm, ticem, tsrfm
+   
+  open(20, file = trim(icerestart), form = 'unformatted', access = 'direct',&
+       recl = reclICE, status = 'old', iostat = ios)
+  if (ios /= 0) then
+     print *, 'ERROR: problem reading "', trim(icerestart), '"'
+     call exit(1)
+  end if
+  open(11, file = 'icevolume.txt', status = 'replace')
+  close(11)
+
+  do iens=1,nens
+     read(20, rec = iens, iostat = ios) ficem, hicem, hsnwm, ticem, tsrfm
+     icevolume(iens) = sum(ficem * hicem, mask = iswater)
+     icearea(iens) = sum(ficem, mask = iswater)
+  end do
+  meanicevolume = sum(icevolume) / real(nens)
+
+  nmissing = 0
+  do iens=1,nens
+     read(20, rec = iens, iostat = ios) ficem, hicem, hsnwm, ticem, tsrfm
+     maxvalue_hicem = maxval(hicem, mask = iswater) ! In meters
+     maxvalue_ticem = maxval(ticem, mask = iswater) ! In Kelvin 
+     maxvalue_tsrfm = maxval(tsrfm, mask = iswater) ! In Kelvin 
+     if (maxvalue_hicem < 0.1  .or. maxvalue_hicem > 100.0 .or. &
+         maxvalue_ticem < 10.0 .or. maxvalue_tsrfm < 10.0) then
+        nmissing = nmissing + 1
+        print '(A, $)', '-'
+        open(10, file = 'missing_icerecords.txt', position = 'append')
+        write(10, '(i4)') iens
+        close(10)
+     elseif (icevolume(iens) /= icevolume(iens) .or. (meanicevolume - icevolume(iens)) / meanicevolume > 0.35) then
+        nmissing = nmissing + 1
+        print '(A, $)', '*'
+        print *, 'member ', iens, ': icevolume = ', icevolume(iens),&
+             ', meanicevolume = ', meanicevolume
+        open(10, file = 'missing_icerecords.txt', position = 'append')
+        write(10, '(i4)') iens
+        close(10)
+     else
+        print '(A, $)', '.'
+     end if
+     open(11, file = 'icevolume.txt', status = 'old', position = 'append')
+     write(11, '(i4, f14.0, f14.0)') iens, icevolume(iens), icearea(iens)
+     close(11)
+  end do
+  close(20)
+  print *, ''
+  if (nmissing > 0) then
+     print *, 'ERROR: ice field is missing for', nmissing, ' member(s)',&
+          ' check "missing_icerecords.txt" for member IDs'
+  end if
+
+end program checkice

EnKF-MPI-TOPAZ/Tools/p_check_ice_en.F90

@@ -0,0 +1,137 @@
+!Fanf A short program to ensure that all member have the ice present.
+!
+! PS: if there are corrupted ic fields - then
+!       (i) the member IDs of these fields will be wrtten to the file
+!           "missing_icerecords.txt"
+!       (ii) this also will be reported to stdout
+!       (iii) and also will be reflected in icevolume.txt
+
+program checkice_en
+  use mod_raw_io
+  use m_parse_blkdat
+  use m_get_mod_grid
+  use m_get_mod_fld
+  implicit none
+  integer*4, external :: iargc
+  integer iens
+  real, dimension(:,:), allocatable :: modlon,modlat,depths
+  logical, allocatable, dimension(:, :) :: iswater
+  integer :: idm,jdm,kdm
+  integer :: ios
+  integer ::  nens
+  real, allocatable, dimension(:,:) :: ficem,hicem,hsnwm,ticem,tsrfm
+  real, allocatable, dimension(:,:) :: fld
+  integer :: reclICE
+  real :: mindx,meandx,rdummy
+  character(len=80) :: icerestart,filename
+  character(len=3) :: ctmp
+  integer :: nmissing
+  real, allocatable, dimension(:) :: icevolume, icearea
+  real :: meanicevolume, maxvalue_hicem, maxvalue_ticem, maxvalue_tsrfm
+  logical :: ex
+
+  if ( iargc()==2 ) then
+     call getarg(1,icerestart)
+     call getarg(2,ctmp)
+     read(ctmp,*) nens
+  else
+     print *,'"check_ice_en" -- A routine to check that no ice records are missing'
+     print *
+     print *,'Usage: checkice_en <surname of ice_file> <ensemble_size>'
+     call exit(1)
+  endif
+
+  !Get model dimensions
+  call parse_blkdat('idm   ','integer',rdummy,idm)
+  call parse_blkdat('jdm   ','integer',rdummy,jdm)
+
+  open(11, file = 'icevolume.txt', status = 'replace')
+  close(11)
+
+  allocate(modlon (idm,jdm))
+  allocate(modlat (idm,jdm))
+  allocate(depths (idm,jdm))
+  allocate(fld (idm,jdm))
+  
+  call get_mod_grid(modlon, modlat, depths, mindx, meandx, idm, jdm)
+
+  allocate(iswater(idm, jdm))
+  iswater = depths > 1.0d0 .and. depths < 1.0e25
+
+  allocate(icevolume(nens))
+  allocate(icearea(nens))
+  icevolume = 0.0d0
+  icearea = 0.0d0
+
+  allocate(ficem(idm,jdm))
+  allocate(hicem(idm,jdm))
+  allocate(hsnwm(idm,jdm))
+  allocate(ticem(idm,jdm))
+  allocate(tsrfm(idm,jdm))
+!  inquire(iolength = reclICE) ficem, hicem, hsnwm, ticem, tsrfm
+   
+!  open(20, file = trim(icerestart), form = 'unformatted', access = 'direct',&
+!       recl = reclICE, status = 'old', iostat = ios)
+!  if (ios /= 0) then
+!     print *, 'ERROR: problem reading "', trim(icerestart), '"'
+!     call exit(1)
+!  end if
+! to check the existing for the mem-file
+  do iens=1,nens
+    write(ctmp,'(i3.3)') iens  
+    filename=trim(icerestart)//trim(ctmp)
+    print *,iens
+    inquire(exist=ex,file=trim(filename)//'.b')
+    if (.not.ex) then
+      write(*,*) 'Can not find '//trim(filename)//'.b'
+      stop '(EnKF_postprocess)'
+    end if
+    call get_mod_fld_new(trim(filename),fld(:,:),1,'ficem   ',0,1,idm,jdm); ficem=fld;
+    call get_mod_fld_new(trim(filename),fld(:,:),1,'hicem   ',0,1,idm,jdm); hicem=fld;
+    icevolume(iens) = sum(ficem * hicem, mask = iswater)
+    icearea(iens) = sum(ficem, mask = iswater)
+  end do
+  open(11, file = 'icevolume.txt', status = 'old', position = 'append')
+    do iens=1,nens
+      write(11, '(i4, f14.0, f14.0)') iens, icevolume(iens), icearea(iens)
+    end do
+  close(11)
+  meanicevolume = sum(icevolume) / real(nens)
+
+  nmissing = 0
+  do iens=1,nens
+    write(ctmp,'(i3.3)') iens  
+    filename=trim(icerestart)//trim(ctmp)
+    call get_mod_fld_new(trim(filename),fld(:,:),1,'hicem   ',0,1,idm,jdm); hicem=fld;
+    call get_mod_fld_new(trim(filename),fld(:,:),1,'ticem   ',0,1,idm,jdm); ticem=fld;
+    call get_mod_fld_new(trim(filename),fld(:,:),1,'tsrfm   ',0,1,idm,jdm); tsrfm=fld;
+     maxvalue_hicem = maxval(hicem, mask = iswater) ! In meters
+     maxvalue_ticem = maxval(ticem, mask = iswater) ! In Kelvin 
+     maxvalue_tsrfm = maxval(tsrfm, mask = iswater) ! In Kelvin 
+     if (maxvalue_hicem < 0.1  .or. maxvalue_hicem > 100.0 .or. &
+         maxvalue_ticem < 10.0 .or. maxvalue_tsrfm < 10.0) then
+        nmissing = nmissing + 1
+        print '(A, $)', '-'
+        open(10, file = 'missing_icerecords.txt', position = 'append')
+        write(10, '(i4)') iens
+        close(10)
+     elseif (icevolume(iens) /= icevolume(iens) .or. (meanicevolume - icevolume(iens)) / meanicevolume > 0.35) then
+        nmissing = nmissing + 1
+        print '(A, $)', '*'
+        print *, 'member ', iens, ': icevolume = ', icevolume(iens),&
+             ', meanicevolume = ', meanicevolume
+        open(10, file = 'missing_icerecords.txt', position = 'append')
+        write(10, '(i4)') iens
+        close(10)
+     else
+        print '(A, $)', '.'
+     end if
+  end do
+! close(20)
+  print *, ''
+  if (nmissing > 0) then
+     print *, 'ERROR: ice field is missing for', nmissing, ' member(s)',&
+          ' check "missing_icerecords.txt" for member IDs'
+  end if
+
+end program checkice_en

EnKF-MPI-TOPAZ/Tools/p_consistency.F90

@@ -0,0 +1,283 @@
+!KAL -- A change of Laurents cosistency program to fit with the new stuff
+!KAL -- it is called on a file-by-file (member - by - member) basis
+!KAL --
+!KAL -- Two argument, the file to check, and the corresponding ensemble member. 
+!KAL -- the latter is needed when checking ice files as well.
+!KAL -- Output file is  consistency_"input_file"
+!KAL
+
+program consistency
+  use mod_raw_io
+  use m_parse_blkdat
+  use m_get_mod_grid
+  use m_get_mod_fld
+  use nfw_mod
+  use mod_testinfo
+  implicit none
+
+  integer*4, external :: iargc
+  integer, parameter :: maxweird = 100 ! give up reporting after 100 weird values 
+  real, parameter :: onem=9806.0, undef=-1e14
+
+  logical isweird                      ! error locally at certain i,j,k
+  integer iens,i,j,k, count_weird ! counting weird values in A
+
+  character(len=80) :: rstfile, rstbase, outfile, icerstfile
+  character(len=8) :: cfld
+  character(len=80) :: cmem
+
+  real, dimension(:,:), allocatable :: readfld,modlon,modlat,depths, dpsum
+  real, dimension(:,:), allocatable :: countprobs, dpprobs, tempprobs
+  real*4, dimension(:,:),  allocatable :: fldr4
+  logical :: process_ice
+  integer :: iter
+  integer :: ncid
+  integer :: dimids(2) 
+  integer :: lon_id, lat_id, tot_id,tem_id, dp_id
+
+  real    :: bmin, bmax
+  real*4  :: amin, amax, spval=0.0
+  integer :: vlevel,tlevel,rstind
+  logical :: readok, ex
+  integer :: testindex
+  integer :: idm,jdm,kdm
+  integer :: ios, fnd
+  integer :: imem, itime
+  real    :: rdummy
+
+  real*8, allocatable, dimension(:,:) :: ficem,hicem,hsnwm,ticem,tsrfm
+  integer :: reclice
+
+  type(testinfo), dimension(:), allocatable :: tests
+  integer :: numtest
+
+  character(len=80) :: ncfile
+  integer :: dimx,dimy,var_id,var2d(2),ierr
+
+   real :: mindx,meandx
+
+   process_ice=.false.
+   imem=1 ! Only really needed when reading ice restart file
+   if (iargc()==1) then
+      call getarg(1,rstfile)
+   elseif (iargc()==3) then
+      call getarg(1,rstfile)
+      call getarg(2,icerstfile)
+      call getarg(3,cmem)
+      read(cmem,*) imem
+      process_ice=.true.
+   else
+      print *,'Usage: consistency restartfile icerestartfile ensemble_member'
+      call exit(1)
+   end if
+   fnd=max(index(rstfile,'.a'),index(rstfile,'.b'))
+   rstbase=rstfile(1:fnd-1)
+
+   ! Set up test info
+   numtest=9
+   allocate(tests(9))
+
+   call tests_init(tests, numtest)
+
+   !Get model dimensions - 
+   call parse_blkdat('idm   ','integer',rdummy,idm)
+   call parse_blkdat('jdm   ','integer',rdummy,jdm)
+   call parse_blkdat('kdm   ','integer',rdummy,kdm)
+
+   ! Allocate fields
+   allocate(readfld(idm,jdm))
+   allocate(fldr4  (idm,jdm))
+   allocate(modlon (idm,jdm))
+   allocate(modlat (idm,jdm))
+   allocate(depths (idm,jdm))
+   allocate(dpsum  (idm,jdm))
+   allocate(countprobs (idm,jdm))
+   allocate(dpprobs    (idm,jdm))
+   allocate(tempprobs  (idm,jdm))
+
+   ! Get model grid
+   call get_mod_grid(modlon,modlat,depths,mindx,meandx,idm,jdm)
+
+   ! Loop through the file header, extract field information, then:
+   !   |--> extract header info
+   !   |--> match header info with test cases
+   !     |--> If match, read field from .a - file
+   !     |--> Check for inconcistencies
+   outfile='consistency_'//trim(rstbase)
+   open(10, file=trim(outfile), access='sequential',status='replace')
+   write(10,*) '**************************************************************'
+   write(10,*) 'THIS FILE CONTAINS ERRORS DETECTED IN THE HYCOM STATE VARIABLE'
+   write(10,*) 'Go to the end of this file for a summary of all errors '
+   write(10,*) '**************************************************************'
+   write(10,*) ''
+   countprobs=0.
+   dpprobs=0.
+   tempprobs=0.
+   rstind=1
+   ios=0
+   count_weird=0
+   readok=.true.
+   do while (readok)
+      ! Get header info
+      call rst_header_from_index(trim(rstbase)//'.b', &
+           cfld,vlevel,tlevel,rstind,bmin,bmax,.true.)
+
+      readok=tlevel/=-1 ! test to see if read was ok
+      if (readok) then
+         call matchtest(cfld,tests,numtest,testindex)
+
+         if (testindex/=-1) then
+            print *,'Checking : ',cfld,vlevel,tlevel
+            call READRAW(fldr4,amin,amax,idm,jdm,.false.,spval,&
+                 trim(rstbase)//'.a',rstind)
+            readfld=fldr4
+
+            write(10,'(a,2i5)') 'Testing '//cfld//' at time and layer :',&
+                 tlevel,vlevel
+
+            do j=1,jdm
+               do i=1,idm
+                  if (depths(i,j)>.1) then
+
+                     isweird=.false.
+                     if (readfld(i,j)>tests(testindex)%max) then
+                        tests(testindex)%toolarge=tests(testindex)%toolarge+1
+                        isweird=.true.
+                     else if (readfld(i,j)<tests(testindex)%min) then
+                        tests(testindex)%toosmall=tests(testindex)%toosmall+1
+                        isweird=.true.
+                     end if
+
+                     if (tests(testindex)%toosmall + tests(testindex)%toolarge&
+                          <maxweird .and. isweird) then
+                        write(10,'(a,4i5,e14.4)') '   '//cfld//'&
+                             Error at i,j,z,t:',i,j,vlevel,tlevel,readfld(i,j)
+                     end if
+
+                     if (isweird) countprobs(i,j)=countprobs(i,j)+1
+                     if (isweird.and.trim(cfld)=='dp')&
+                          dpprobs(i,j)=dpprobs(i,j)+1
+                     if (isweird.and.trim(cfld)=='temp')&
+                          tempprobs(i,j)=tempprobs(i,j)+1
+                  end if
+               end do
+            end do
+
+            if ( tests(testindex)%toosmall + tests(testindex)%toolarge&
+                 >=maxweird) then
+               write(10,*) 'Found ', tests(testindex)%toosmall +&
+                    tests(testindex)%toolarge,' errors for ', cfld
+            end if
+         else
+            print *,'Skipping : ',cfld,vlevel,tlevel
+         end if
+      end if
+
+      rstind=rstind+1
+   end do
+
+   ! KAL -- test 2, see if layer thicknesses sum up to depths*onem
+   do itime=1,2
+      dpsum=0.
+      do k=1,kdm
+         call get_mod_fld_new(trim(rstbase),readfld,imem,'dp      ',k,itime,&
+              idm,jdm)
+         dpsum=dpsum+readfld
+      end do
+      print '(a,i3)','Max difference dpsum / depths at time index ',itime
+      print *,maxval(dpsum-depths*onem)/onem
+   end do
+
+   ! KAL -- test 3, see if ice thickness 
+   if (process_ice) then
+      allocate(ficem(idm,jdm))
+      allocate(hicem(idm,jdm))
+      allocate(hsnwm(idm,jdm))
+      allocate(ticem(idm,jdm))
+      allocate(tsrfm(idm,jdm))
+
+      print *,'TODO -- check ice fields'
+      inquire(iolength=reclICE)ficem,hicem,hsnwm,ticem,tsrfm  !,iceU,iceV
+      open(20,file=trim(icerstfile),form='unformatted',access='direct',recl=reclICE,status='old')
+      read(20,rec=imem,iostat=ios)ficem,hicem,hsnwm,ticem,tsrfm !,iceU,iceV
+      close(20)
+
+      do iter=1,2
+         if (iter==1) then
+            cfld='icec'
+            call matchtest(cfld,tests,numtest,testindex)
+            readfld=ficem
+         else if (iter==2) then
+            cfld='hice'
+            call matchtest(cfld,tests,numtest,testindex)
+            readfld=hicem
+         end if
+
+         if (testindex/=-1) then
+            write(10,'(a,2i5)') 'Testing '//cfld//' at time and layer :',&
+                 tlevel,vlevel
+
+            do j=1,jdm
+               do i=1,idm
+                  if (depths(i,j)>.1) then
+                     isweird=.false.
+                     if (readfld(i,j)>tests(testindex)%max) then
+                        tests(testindex)%toolarge=tests(testindex)%toolarge+1
+                        isweird=.true.
+                     else if (readfld(i,j)<tests(testindex)%min) then
+                        tests(testindex)%toosmall=tests(testindex)%toosmall+1
+                        isweird=.true.
+                     end if
+                     
+                     if (tests(testindex)%toosmall + tests(testindex)%toolarge&
+                          <maxweird .and. isweird) then
+                        write(10,'(a,4i5,e14.4)') '   '//cfld//&
+                             ' Error at i,j,z,t:',i,j,vlevel,tlevel,readfld(i,j)
+                     end if
+                  end if
+
+                  if (isweird) countprobs(i,j)=countprobs(i,j)+1
+               end do
+            end do
+
+            if (tests(testindex)%toosmall + tests(testindex)%toolarge&
+                 >=maxweird) then
+               write(10,*) 'Found ', tests(testindex)%toosmall +  tests(testindex)%toolarge,' errors for ',cfld
+            end if
+
+         end if
+      end do
+   end if
+   close(10)
+
+   print *,minval(countprobs),maxval(countprobs)
+   where (depths<.1) 
+      countprobs=undef
+      dpprobs=undef
+      tempprobs=undef
+   end where
+   print *,minval(countprobs),maxval(countprobs)
+
+   ! Netcdf - distribution of "problematic" areas
+
+   ncfile=trim(outfile)//'.nc'
+   call nfw_create(ncfile, nf_clobber, ncid)
+   call nfw_def_dim(ncfile, ncid, 'idm', idm, dimids(1))
+   call nfw_def_dim(ncfile, ncid, 'jdm', jdm, dimids(2))
+   call nfw_def_var(ncfile, ncid, 'lon', nf_float, 2, dimids, lon_id)
+   call nfw_def_var(ncfile, ncid, 'lat', nf_float, 2, dimids, lat_id)
+   call nfw_def_var(ncfile, ncid, 'tempprob', nf_float, 2, dimids, tem_id)
+   call nfw_def_var(ncfile, ncid, 'totprob', nf_float, 2, dimids, tot_id)
+   call nfw_def_var(ncfile, ncid, 'dpprob', nf_float, 2, dimids, dp_id)
+   call nfw_enddef(ncfile, ncid)
+
+   call nfw_put_var_double(ncfile, ncid, lon_id, modlon)
+   call nfw_put_var_double(ncfile, ncid, lat_id, modlat)
+   call nfw_put_var_double(ncfile, ncid, tot_id, countprobs)
+   call nfw_put_var_double(ncfile, ncid, tem_id, tempprobs)
+   call nfw_put_var_double(ncfile, ncid, dp_id, dpprobs)
+   call nfw_close(ncfile, ncid)
+
+
+
+end program consistency

EnKF-MPI-TOPAZ/Tools/p_fixhycom.F90

@@ -0,0 +1,320 @@
+! File:          p_fixhycom.F90
+!
+! Created:       ???
+!
+! Last modified: 29/06/2010
+!
+! Purpose:       Fixes EnKF output.
+!
+! Description:   
+!
+! Modifications:
+!                25/10/2011 FC:
+!                  - set the two time levels equal
+!                29/06/2010 PS:
+!                  - set the maximum ICEC to 0.995 to match the model
+!                ?/?/? KAL:
+!                  - Modification of the "fixhycom" subroutine, into separate
+!                    program, working on a file-by-file basis
+!                Prior history:
+!                  Not documented.
+
+! KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 
+! KAL -- Input arguments:
+! KAL --     template restart file
+! KAL --     ensemble member
+! KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 
+
+program fixhycom
+
+
+
+
+   use mod_raw_io
+   use m_parse_blkdat
+   use m_put_mod_fld
+   use m_get_mod_fld
+   use m_get_mod_grid
+   implicit none
+
+   integer*4, external :: iargc
+   real, parameter :: onem=9806.
+   real, parameter :: PSTARB0 = 1000;
+
+   integer imem                  ! ensemble member
+   character(len=80) :: restart,icerestart ! restart template
+
+   character(len=80) :: afile,newfile, char80
+   integer          :: fnd, rstind, tmpindx, iafile
+   logical          :: ex, allok, nomatch
+   character(len=8) :: cfld, ctmp
+   character(len=3) :: cproc,cmem
+   integer          :: tlevel, vlevel, nproc
+   real             :: bmin, bmax, rdummy
+   integer          :: idm,jdm,kdm
+   real, allocatable:: fld(:,:)
+   real*8, allocatable, dimension(:,:) :: &
+      ficem,hicem,hsnwm,ticem,tsrfm
+   real, allocatable, dimension(:,:) :: depths,modlon,modlat,saln
+   real*4, allocatable:: fldr4(:,:)
+   real*4 :: spval,amin,amax
+   real, allocatable :: press(:)
+
+   real, allocatable, dimension(:,:)   :: dpsum
+   real, allocatable, dimension(:,:,:)   :: dp, dpold
+
+   integer,parameter :: numfields=2
+   integer :: ios,ios2, reclICE,ifld
+   integer :: i,j,k
+
+   real :: mindx,meandx
+
+
+   icerestart=''
+   if (iargc()==2 .or. iargc()==3) then
+      call getarg(1,restart)
+      call getarg(2,ctmp)
+      read(ctmp,*) imem
+      write(cmem,'(i3.3)') imem
+      if (iargc()==3) call getarg(3,icerestart)
+   else
+      print *,'"fixhycom" -- A crude routine to correct restart files for obvious errors'
+      print *
+      print *,'usage: '
+      print *,'   fixhycom restart_file ensemble_member <ice_file>'
+      print *,'   "restart_file"    the restart file you want to fix (.a-file)"'
+      print *,'   "ensemble_member" is the ensemble member - should corr. to that of restart file'
+      print *,'   "ice_file"        is optional - it is the restart file for ice fields'
+      call exit(1)
+   endif
+
+   ! Get dimensions from blkdat
+   call parse_blkdat('idm   ','integer',rdummy,idm)
+   call parse_blkdat('jdm   ','integer',rdummy,jdm)
+   call parse_blkdat('kdm   ','integer',rdummy,kdm)
+
+   if (idm>0 .and. idm < 1e4 .and. jdm>0 .and. jdm<1e4) then
+      allocate(fld  (idm,jdm))
+      allocate(fldr4(idm,jdm))
+      allocate(saln (idm,jdm))
+      allocate(ficem(idm,jdm))
+      allocate(hicem(idm,jdm))
+      allocate(hsnwm(idm,jdm))
+      allocate(ticem(idm,jdm))
+      allocate(tsrfm(idm,jdm))
+      allocate(dpsum(idm,jdm))
+      allocate(depths(idm,jdm))
+      allocate(modlon(idm,jdm))
+      allocate(modlat(idm,jdm))
+      allocate(dpold(idm,jdm,kdm))
+      allocate(dp   (idm,jdm,kdm))
+      allocate(press(kdm+1))
+   else
+      print *,'fld allocate error'
+      stop '(EnKF_postprocess)'
+   end if
+
+
+   ! Remove postfix of restart file
+   fnd=max(index(restart,'.a'),index(restart,'.b'))
+
+
+   ! Inquire for existence
+   inquire(exist=ex,file=restart(1:fnd-1)//'.b')
+   if (.not.ex) then
+      write(*,*) 'Can not find '//restart(1:fnd-1)//'.b'
+      stop '(EnKF_postprocess)'
+   end if
+
+   print *,restart(1:fnd-1)//'.b'
+   newfile='fix'//restart(1:fnd-1)
+
+
+   ! Get model grid
+   call get_mod_grid(modlon,modlat,depths,mindx,meandx,idm,jdm)
+
+   !loop over the two time level
+   ! Get layer thickness
+   dpsum=0.
+   do k=1,kdm
+      call get_mod_fld_new(restart(1:fnd-1),dp(:,:,k),imem,'dp      ',k,1,idm,jdm)
+      dpsum=dpsum+dp(:,:,k)
+   end do
+   dpold=dp(:,:,:)
+
+
+   ! DP correction
+   do j=1,jdm
+   do i=1,idm
+
+      !!! Move negative layers to neighbouring layers.
+      do k = 1, kdm-1
+         dp(i,j,k+1) = dp(i,j,k+1) + min(0.0,dp(i,j,k))
+         dp(i,j,k  ) = max(dp(i,j,k),0.0)
+      end do
+
+      !!! Go backwards to fix lowermost layer.
+      do k = kdm, 3, -1
+         dp(i,j,k-1) = dp(i,j,k-1) + min(0.0,dp(i,j,k))
+         dp(i,j,k  ) = max(dp(i,j,k),0.0)
+      end do
+      !!! No layers below the sea bed.
+      press(  1) = 0.0         
+      do k = 1, kdm-1
+         press(k+1) = press(k) + dp(i,j,k)
+         press(k+1) = min(depths(i,j)*onem,press(k+1))
+      end do
+      press(kdm+1) = depths(i,j)*onem
+
+      do k = 1, kdm
+         dp(i,j,k) = press(k+1) - press(k)
+      end do
+      if (depths(i,j)>100000. .or. depths(i,j) < 1. ) then
+        dp(i,j,:)=dpold(i,j,:)
+      endif
+   end do
+   end do
+   do k = 1, kdm
+      print *,'max diff is:',maxval(dpold(:,:,k)-dp(:,:,k))/onem,maxloc(dpold(:,:,k)-dp(:,:,k))
+   end do
+
+
+
+   ! Loop over restart file
+   rstind=1 ! Restart index
+   allok=.true.
+   do while ( allok)
+
+      ! Get header info from restart
+      call rst_header_from_index(restart(1:fnd-1)//'.b', &
+            cfld,vlevel,tlevel,rstind,bmin,bmax,.true.)
+
+      allok=tlevel/=-1 ! test to see if read was ok
+
+      print *,cfld
+
+
+
+      if (allok ) then 
+!         Here reading the time record 1 whatever tlevel
+         call get_mod_fld_new(restart(1:fnd-1),fld(:,:),imem,cfld,vlevel,1,idm,jdm)
+
+
+         if (trim(cfld)=='temp') then
+
+            ! need salinity as well
+            ! reading the time record 1 whatever tlevel
+            call get_mod_fld_new(restart(1:fnd-1),saln(:,:),imem,'saln    ',vlevel,1,idm,jdm)
+            ! keep water warmer than freezing point
+            do j=1,jdm
+            do i=1,idm
+               fld(i,j)=max(-.057*saln(i,j),fld(i,j))
+               fld(i,j)=min(fld(i,j),35.0) !cut off values that are too warm :FC
+            end do
+            end do
+         else if (trim(cfld)=='saln') then
+           do j=1,jdm
+           do i=1,idm
+              fld(i,j)=max(5.,fld(i,j)) ! LB :no water fresher than 5 psu (Baltic)
+              fld(i,j)=min(41.,fld(i,j)) ! FC :no water saltier than 40 psu 
+           end do
+           end do
+         else if (trim(cfld)=='pstarb') then
+              fld(:,:) = (sqrt(PSTARB0 ** 2 + fld(:,:) ** 2) + fld(:,:)) / 2.0d0;
+         else if (trim(cfld)=='dp') then
+            !set it equal to the time level 1 that has been corrected
+            fld = dp(:,:,vlevel) 
+#if defined (TOPAZ)
+! in west of Mediterranean
+          else if (trim(cfld)=='pbavg' .or. trim(cfld)=='ubavg' .or. trim(cfld)=='vbavg'&
+                 .or. trim(cfld)=='u' .or. trim(cfld)=='v') then
+            do i = 701, 704
+              do j = 482, 484
+                  fld(i, j) = 0.0d0
+              end do
+            end do
+#endif
+#if defined (SINGLE_RESTART)
+         else if (trim(cfld)=='ficem') then
+           do j=1,jdm
+             do i=1,idm
+               fld(i,j)=min(max(0.,fld(i,j)),0.995) 
+             end do
+           end do
+         else if (trim(cfld)=='hicem') then
+           do j=1,jdm
+             do i=1,idm
+               fld(i,j)=min(max(0.,fld(i,j)),15.) 
+             end do
+           end do
+         else if (trim(cfld)=='hsnwm') then
+           do j=1,jdm
+             do i=1,idm
+               fld(i,j)=min(max(0.,fld(i,j)),0.4) 
+             end do
+           end do
+#endif
+         end if ! No correction for other fields in the hycom restart file
+         !dump the field from the first time level into tlevel (1 or 2)
+         call put_mod_fld(trim(newfile),fld,imem,cfld,vlevel,tlevel,rstind,idm,jdm)
+         rstind=rstind+1
+      end if ! read of template was ok
+   end do
+
+
+   ! put_mod_fld does not include the header from the original file
+   open(10,file=trim(newfile)//'.b',status='old')
+   open(20,file=restart(1:fnd-1)//'.b',status='old')
+   ! Supports parallel execution with different members
+   open(11,file='tmp'//cmem//'.b',status='replace')
+
+   ! Header from original file
+   read(20,'(a80)') char80 ; write(11,'(a80)') char80
+   read(20,'(a80)') char80 ; write(11,'(a80)') char80
+   close(20)
+
+   ! The rest from the newly created file
+   ios=0
+   do while(ios==0)
+      read(10,'(a80)',iostat=ios) char80  
+      if (ios==0) write(11,'(a80)') char80
+   end do
+
+   close(10)
+   close(11)
+   close(20)
+
+   ! Move the new .b file to "newfile"
+   !SERIAL call system('mv tmp'//cmem//'.b '//trim(newfile)//'.b')
+
+
+
+!###################################################################
+!####################### FIX   ICE   MODEL #########################
+!###################################################################
+#if ! defined (SINGLE_RESTART)
+   if (iargc()==3) then
+
+      inquire(exist=ex,file=trim(icerestart))
+      if (.not.ex) then
+         print *,icerestart//' does not exist!'
+         print *,'(fixhycom)'
+         stop
+      end if
+
+      inquire(iolength=reclICE)ficem,hicem,hsnwm,ticem,tsrfm  !,iceU,iceV
+      open(10,file=icerestart,form='unformatted',access='direct',recl=reclICE)
+      read(10,rec=imem)ficem,hicem,hsnwm,ticem,tsrfm !,iceU,iceV
+      close(10)
+
+      ! PS 25/06/2010 max(ficem) = 0.995 - max the model allows
+      ficem=min(max(0.,ficem), 0.995)
+      hicem=min(max(0.,hicem),15.)
+      hsnwm=min(max(0.,hsnwm), 4.)
+
+      open (10,file='fix'//trim(icerestart),form='unformatted',access='direct',recl=reclICE)
+      write(10,rec=imem)ficem,hicem,hsnwm,ticem,tsrfm 
+      close(10)
+   end if
+#endif
+end program

EnKF-MPI-TOPAZ/Tools/p_fixhycom_eco.F90

@@ -0,0 +1,518 @@
+! File:          p_fixhycom.F90
+!
+! Created:       ???
+!
+! Last modified: 29/06/2010
+!
+! Purpose:       Fixes EnKF output.
+!
+! Description:   
+!
+! Modifications:
+!                1/03/2011 Ehouarn:
+!                  -modification of the fixhycom subroutine: interpolation of 
+!                    biogeochemical tracers on the analysis grid according to
+!                    hycom remapping in order to insure conservation.  
+!                29/06/2010 PS:
+!                  - set the maximum ICEC to 0.995 to match the model
+!                ?/?/? KAL:
+!                  - Modification of the "fixhycom" subroutine, into separate
+!                    program, working on a file-by-file basis
+!                Prior history:
+!                  Not documented.
+
+! KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 
+! KAL -- Input arguments:
+! KAL --     template restart file
+! KAL --     ensemble member
+! KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 
+! KAL -- TODO: Fix for ice fields
+
+program fixhycom_eco
+
+
+
+
+   use mod_raw_io
+   use m_parse_blkdat
+   use m_put_mod_fld
+   use m_get_mod_fld
+   use m_get_mod_grid
+#if defined (ECO)
+   use m_fixhycom_eco_metno
+#endif   
+   implicit none
+
+   integer*4, external :: iargc
+   real, parameter :: onem=9806.
+   real, parameter :: PSTARB0 = 1000;
+
+   integer imem                  ! ensemble member
+   character(len=80) :: restart,icerestart ! restart template
+
+   character(len=80) :: afile,newfile, char80
+   integer          :: fnd, rstind, tmpindx, iafile
+   logical          :: ex, allok, nomatch
+   character(len=8) :: cfld, ctmp
+   character(len=3) :: cproc,cmem
+   integer          :: tlevel, vlevel, nproc
+   real             :: bmin, bmax, rdummy
+   integer          :: idm,jdm,kdm
+   real, allocatable:: fld(:,:)
+   real*8, allocatable, dimension(:,:) :: &
+      ficem,hicem,hsnwm,ticem,tsrfm
+   real, allocatable, dimension(:,:) :: depths,modlon,modlat,saln
+   real*4, allocatable:: fldr4(:,:)
+   real*4 :: spval,amin,amax
+   real, allocatable :: press(:)
+
+   real, allocatable, dimension(:,:)   :: dpsum
+   real, allocatable, dimension(:,:,:)   :: dp, dpold
+
+   integer,parameter :: numfields=2
+   integer :: ios,ios2, reclICE,ifld
+   integer :: i,j,k,ktr
+
+   real :: mindx,meandx
+   
+#if defined (ECO)   
+    real,dimension(:,:,:), allocatable::dpfor,cfi 
+    character(len=80) :: restfor
+    real,dimension(:,:,:,:), allocatable::tracerf
+    real, dimension(:,:), allocatable::trcraij
+    real, dimension(:), allocatable::prsf,dpf
+    integer::ntracr,ktrcr
+    real::dpthin
+    character(2)::ctrcr
+    logical, dimension(:), allocatable::lcm
+    
+    real, dimension(:,:,:), allocatable::temp,sal
+    integer::kisop
+#endif
+
+   icerestart=''
+   if (iargc()==2 .or. iargc()==3) then
+      call getarg(1,restart)
+      call getarg(2,ctmp)
+      read(ctmp,*) imem
+      write(cmem,'(i3.3)') imem
+      if (iargc()==3) call getarg(3,icerestart)
+   else
+      print *,'"fixhycom" -- A crude routine to correct restart files for obvious errors'
+      print *
+      print *,'usage: '
+      print *,'   fixhycom restart_file ensemble_member <ice_file>'
+      print *,'   "restart_file"    the restart file you want to fix (.a-file)"'
+      print *,'   "ensemble_member" is the ensemble member - should corr. to that of restart file'
+      print *,'   "ice_file"        is optional - it is the restart file for ice fields'
+      call exit(1)
+   endif
+
+   ! Get dimensions from blkdat
+   call parse_blkdat('idm   ','integer',rdummy,idm)
+   call parse_blkdat('jdm   ','integer',rdummy,jdm)
+   call parse_blkdat('kdm   ','integer',rdummy,kdm)
+#if defined (ECO)
+   call parse_blkdat('ntracr','integer',rdummy,ntracr) 	  
+#endif
+      
+   if (idm>0 .and. idm < 1e4 .and. jdm>0 .and. jdm<1e4) then
+      allocate(fld  (idm,jdm))
+      allocate(fldr4(idm,jdm))
+      allocate(saln (idm,jdm))
+      allocate(ficem(idm,jdm))
+      allocate(hicem(idm,jdm))
+      allocate(hsnwm(idm,jdm))
+      allocate(ticem(idm,jdm))
+      allocate(tsrfm(idm,jdm))
+      allocate(dpsum(idm,jdm))
+      allocate(depths(idm,jdm))
+      allocate(modlon(idm,jdm))
+      allocate(modlat(idm,jdm))
+      allocate(dpold(idm,jdm,kdm))
+      allocate(dp   (idm,jdm,kdm))
+      allocate(press(kdm+1))
+#if defined (ECO)
+      allocate(dpfor(idm,jdm,kdm))
+      allocate(cfi(kdm,ntracr,2))
+      allocate(prsf(kdm+1))
+      allocate(tracerf(idm,jdm,kdm,ntracr))
+      allocate(trcraij(kdm,ntracr))
+      allocate(lcm(kdm))
+      allocate(dpf(kdm))
+      allocate(sal(idm,jdm,kdm))
+      allocate(temp(idm,jdm,kdm))
+#endif
+   else
+      print *,'fld allocate error'
+      stop '(EnKF_postprocess)'
+   end if
+
+
+   ! Remove postfix of restart file
+   fnd=max(index(restart,'.a'),index(restart,'.b'))
+
+
+   ! Inquire for existence
+   inquire(exist=ex,file=restart(1:fnd-1)//'.b')
+   if (.not.ex) then
+      write(*,*) 'Can not find '//restart(1:fnd-1)//'.b'
+      stop '(EnKF_postprocess)'
+   end if
+
+   print *,restart(1:fnd-1)//'.b'
+   newfile='fix'//restart(1:fnd-1)
+
+
+   ! Get model grid
+   call get_mod_grid(modlon,modlat,depths,mindx,meandx,idm,jdm)
+
+#if defined (ECO)
+   !files where are stored the forecast fields!
+   restfor='forecast'//cmem
+   dpthin = onem*0.001
+#endif
+
+   ! Get layer thickness
+   dpsum=0.
+   do k=1,kdm
+      !call get_mod_fld(dp(:,:,k),1,'dp      ',k,1)
+      call get_mod_fld_new(restart(1:fnd-1),dp(:,:,k),imem,'dp      ',k,1,idm,jdm)
+      dpsum=dpsum+dp(:,:,k)
+#if defined (ECO)
+      !reading of forecast fields: tracers, T and S
+      call get_mod_fld_new(trim(restfor),dpfor(:,:,k),imem,'dp    ',k,1,idm,jdm)
+      do ktrcr=1,ntracr
+         write(ctrcr,'(i2.2)') ktrcr
+         cfld='tracer'//ctrcr
+         call get_mod_fld_new(trim(restfor),tracerf(:,:,k,ktrcr),imem,cfld,k,1,idm,jdm)
+      enddo
+      call get_mod_fld_new(trim(restfor),temp(:,:,k),imem,'temp    ',k,1,idm,jdm)
+      call get_mod_fld_new(trim(restfor),sal(:,:,k),imem,'saln    ',k,1,idm,jdm)
+#endif      
+   end do
+   print *,maxval(dpsum-depths*onem)
+   dpold=dp
+
+
+
+   ! DP correction
+   do j=1,jdm
+   do i=1,idm
+
+      !!! Move negative layers to neighbouring layers.
+      do k = 1, kdm-1
+         dp(i,j,k+1) = dp(i,j,k+1) + min(0.0,dp(i,j,k))
+         dp(i,j,k  ) = max(dp(i,j,k),0.0)
+         !dp(i,j,k  ) = max(dp(i,j,k),1.e-3*onem)
+      end do
+
+      !!! Go backwards to fix lowermost layer.
+      do k = kdm, 3, -1
+         dp(i,j,k-1) = dp(i,j,k-1) + min(0.0,dp(i,j,k))
+         dp(i,j,k)   =   max(dp(i,j,k),0.0)
+	 !dp(i,j,k)   =   max(dp(i,j,k),1.e-3*onem)
+      end do
+
+      !!! No layers below the sea bed.
+      press(  1) = 0.0
+#if defined (ECO)
+      !computation of the forecast layer interfaces (prsf)!
+      prsf(1)=0.
+#endif               
+      do k = 1, kdm-1
+         press(k+1) = press(k) + dp(i,j,k)
+         press(k+1) = min(depths(i,j)*onem,press(k+1))
+#if defined (ECO)
+         prsf(k+1) = prsf(k) + dpfor(i,j,k)
+#endif 	 
+      end do
+      press(kdm+1) = depths(i,j)*onem
+#if defined (ECO)
+      prsf(kdm+1)=depths(i,j)*onem
+#endif     
+
+      do k = 1, kdm
+         dp(i,j,k) = press(k+1) - press(k)
+#if defined (ECO)
+         !definition of the isopycnal layers!
+         dpf(k)=max(dpfor(i,j,k),dpthin) 
+         kisop=compute_kisop(temp(i,j,:),sal(i,j,:),kdm)
+         if     (k.le.max(2,kisop)) then
+          lcm(k) = .false.  !fixed layers are never PCM
+         else
+! ---       thin and isopycnal layers remapped with PCM.
+            lcm(k) = dpfor(i,j,k).le.dpthin
+         endif 
+#endif  	       
+      end do
+
+!eho 2/11/11      
+      if(depths(i,j)>10000. .or. depths(i,j)<1.)then
+        dp(i,j,:)=dpold(i,j,:)
+      endif
+      
+#if defined (ECO)     
+!      if(depths(i,j)==0.)then
+      if(depths(i,j)>10000. .or. depths(i,j)<1.)then
+        cycle
+      else	
+	call hybgen_weno_coefs(tracerf(i,j,:,:),dpf,lcm,cfi,kdm,ntracr,dpthin)
+        call hybgen_weno_remap(tracerf(i,j,:,:),prsf,dpfor(i,j,:),cfi,trcraij,&
+                        press,kdm,kdm,ntracr,dpthin)
+        tracerf(i,j,1:kdm,1:ntracr)=trcraij(1:kdm,1:ntracr)  
+      endif
+      
+#endif
+      
+   end do
+   end do
+
+   do k = 1, kdm
+      print *,maxval(dpold(:,:,k)-dp(:,:,k))/onem
+   end do
+
+#if defined (ECO)     
+   deallocate(trcraij,dpf,lcm,cfi,prsf,dpfor)
+#endif
+
+
+
+
+
+   ! Loop over restart file
+   rstind=1 ! Restart index
+   allok=.true.
+   do while ( allok)
+
+      ! Get header info from restart
+      call rst_header_from_index(restart(1:fnd-1)//'.b', &
+            cfld,vlevel,tlevel,rstind,bmin,bmax,.true.)
+
+      allok=tlevel/=-1 ! test to see if read was ok
+
+      print *,cfld
+
+
+
+      if (allok) then 
+
+         ! Get actual field  - for now we use the READRAW routine (later on we
+         ! should switch to m_get_mod_fld
+!         call READRAW(fldr4,amin,amax,idm,jdm,.false.,spval,restart(1:fnd-1)//'.a',rstind)
+!         fld=fldr4
+
+         ! Sjekk p at vi har lest rett - samanlign max/min fr filene
+!         if     (abs(amin-bmin).gt.abs(bmin)*1.e-4 .or. &
+!                 abs(bmax-amax).gt.abs(bmax)*1.e-4     ) then
+!            print *,'Inconsistency between .a and .b files'
+!            print *,'.a : ',amin,amax
+!            print *,'.b : ',bmin,bmax
+!            print *,cfld,vlevel,tlevel
+!            call exit(1)
+!         end if
+
+	 call get_mod_fld_new(restart(1:fnd-1),fld(:,:),imem,cfld,vlevel,1,idm,jdm)
+
+         if (trim(cfld)=='temp') then
+
+            ! need salinity as well
+            call get_mod_fld_new(restart(1:fnd-1),saln(:,:),imem,'saln    ',vlevel,1,idm,jdm)
+
+            !if (tlevel==-1) then
+            !   print *,'Could not get salinity field'
+            !   call exit(1)
+            !end if
+
+            ! keep water warmer than freezing point
+            do j=1,jdm
+            do i=1,idm
+               fld(i,j)=max(-.057*saln(i,j),fld(i,j))
+               fld(i,j)=min(35.,fld(i,j)) !FC: cut off values that are too warm
+            end do
+            end do
+         else if (trim(cfld)=='saln') then
+           do j=1,jdm
+           do i=1,idm
+              fld(i,j)=max(5.,fld(i,j)) ! LB :no water fresher than 5 psu (Baltic)
+              fld(i,j)=min(41.,fld(i,j))! FC: no water saltier than 40 psu
+           end do
+           end do
+         else if (trim(cfld)=='pstarb') then
+              fld(:,:) = (sqrt(PSTARB0 ** 2 + fld(:,:) ** 2) + fld(:,:)) / 2.0d0;
+         else if (trim(cfld)=='dp') then
+            fld = dp(:,:,vlevel) ! NB, one time level 
+#if defined (ECO)  
+         else if (cfld(1:6)=='tracer') then  	    
+	    !updating the file!
+	    ktrcr=tracr_get_incr(cfld(7:8))
+	    if (ktrcr==-1)then
+	      print*,'alert tracer unknow'
+	      exit
+	    endif
+            fld(:,:)= tracerf(:,:,vlevel,ktrcr)
+	    
+#endif	 
+	 end if ! No correction for other fields in the hycom restart file
+
+         call put_mod_fld(trim(newfile),fld,imem,cfld,vlevel,tlevel,rstind,idm,jdm)
+
+
+            
+         rstind=rstind+1
+      end if ! read of template was ok
+   end do
+
+#if defined (ECO)
+   deallocate(tracerf)
+#endif
+
+
+   ! put_mod_fld does not include the header from the original file
+   open(10,file=trim(newfile)//'.b',status='old')
+   open(20,file=restart(1:fnd-1)//'.b',status='old')
+   ! Supports parallel execution with different members
+   open(11,file='tmp'//cmem//'.b',status='replace')
+
+   ! Header from original file
+   read(20,'(a80)') char80 ; write(11,'(a80)') char80
+   read(20,'(a80)') char80 ; write(11,'(a80)') char80
+   close(20)
+
+   ! The rest from the newly created file
+   ios=0
+   do while(ios==0)
+      read(10,'(a80)',iostat=ios) char80  
+      if (ios==0) write(11,'(a80)') char80
+   end do
+
+   close(10)
+   close(11)
+   close(20)
+
+   ! Move the new .b file to "newfile"
+   !SERIAL call system('mv tmp'//cmem//'.b '//trim(newfile)//'.b')
+
+
+
+!###################################################################
+!####################### FIX   ICE   MODEL #########################
+!###################################################################
+
+
+
+
+
+   if (iargc()==3) then
+
+      inquire(exist=ex,file=trim(icerestart))
+      if (.not.ex) then
+         print *,icerestart//' does not exist!'
+         print *,'(fixhycom)'
+         stop
+      end if
+
+      inquire(iolength=reclICE)ficem,hicem,hsnwm,ticem,tsrfm  !,iceU,iceV
+      open(10,file=icerestart,form='unformatted',access='direct',recl=reclICE)
+      read(10,rec=imem)ficem,hicem,hsnwm,ticem,tsrfm !,iceU,iceV
+      close(10)
+
+      ! PS 25/06/2010 max(ficem) = 0.995 - max the model allows
+      ficem=min(max(0.,ficem), 0.995)
+      hicem=min(max(0.,hicem),15.)
+      hsnwm=min(max(0.,hsnwm), 4.)
+
+      open (10,file='fix'//trim(icerestart),form='unformatted',access='direct',recl=reclICE)
+      write(10,rec=imem)ficem,hicem,hsnwm,ticem,tsrfm !,iceU,iceV
+      close(10)
+   end if
+      
+
+
+
+
+!KAL
+!KAL   ! This is to make it easier for supporting programs
+!KAL   open(10,file='file.EnKF_postprocess',status='replace')
+!KAL   write(10,'(a)') 'analysis'//cmem
+!KAL   close(10)
+!KAL
+!KAL
+!KAL
+!KAL   ! ice processing Loop over restart file
+!KAL   print *
+!KAL   print *
+!KAL   print *,'processing ice restart file'
+!KAL   rstind=1 ! Restart index
+!KAL   allok=.true.
+!KAL   call system("cp ensemble_TMP_ICE.uf ensemble_TMP_ICE_final.uf")
+!KAL   do ifld=1,numfields
+!KAL      cfld=  fieldnames (ifld)
+!KAL      vlevel=fieldlevels(ifld)
+!KAL      if (trim(cfld)=='icec' .or. trim(cfld)=='hice') then
+!KAL         nomatch=.true.
+!KAL         do iafile=1,nproc ! List of procs used in analysis
+!KAL            write(cproc,'(i3.3)') iafile-1
+!KAL
+!KAL            ! NB - time level=1
+!KAL            ! NB2 - the files dumped in the analysis lack a header (last argument
+!KAL            ! is false)
+!KAL            call rst_index_from_header(trim(afile)//'.b',cfld,vlevel,1, &
+!KAL                                             tmpindx,bmin,bmax,.false.) 
+!KAL
+!KAL
+!KAL            if (tmpindx/=-1) then
+!KAL               print '(a8," -- layer:",i4,"  match : record, file",i4," ",a)', cfld, vlevel,tmpindx,trim(afile)
+!KAL               nomatch=.false.
+!KAL               exit
+!KAL            end if
+!KAL
+!KAL            ! Read field from analysed file 
+!KAL            call READRAW(fldr4,amin,amax,idm,jdm,.false.,spval,trim(afile)//'.a',tmpindx)
+!KAL            fld=fldr4
+!KAL
+!KAL           ! Sjekk p at vi har lest rett - samanlign max/min fr filene
+!KAL           if     (abs(amin-bmin).gt.abs(bmin)*1.e-4 .or. &
+!KAL                   abs(bmax-amax).gt.abs(bmax)*1.e-4     ) then
+!KAL              print *,'Inconsistency between .a and .b files'
+!KAL              print *,'.a : ',amin,amax
+!KAL              print *,'.b : ',bmin,bmax
+!KAL              print *,cfld,vlevel,tlevel
+!KAL              call exit(1)
+!KAL           end if
+!KAL
+!KAL         end do
+!KAL
+!KAL
+!KAL         ! Check if we got ice concentration or ice thickness
+!KAL         if (.not.nomatch) then
+!KAL
+!KAL
+!KAL            inquire(iolength=reclICE)ficem,hicem,hsnwm,ticem,tsrfm  !,iceU,iceV
+!KAL            open(10,file=trim(icetemplate),form='unformatted',access='direct',recl=reclICE,status='old')
+!KAL            open(11,file='ensemble_TMP_ICE_final.uf',form='unformatted',access='direct',recl=reclICE,status='unknown')
+!KAL            read(10,rec=imem,iostat=ios)ficem,hicem,hsnwm,ticem,tsrfm !,iceU,iceV
+!KAL            if (trim(cfld)=='icec') ficem=fld
+!KAL            if (trim(cfld)=='hice') hicem=fld
+!KAL            write(11,rec=imem,iostat=ios2)ficem,hicem,hsnwm,ticem,tsrfm !,iceU,iceV
+!KAL            close(10)
+!KAL            close(11)
+!KAL
+!KAL            if (ios/=0 .or.ios2/=0) then
+!KAL               print *,ios
+!KAL               print *,ios2
+!KAL               print *,'Error when writing to ice ens file'
+!KAL               call exit(1)
+!KAL            end if
+!KAL         end if
+!KAL      end if
+!KAL   end do
+!KAL
+!KAL
+!KAL   print *,'Normal exit of EnKF_postprocess'
+!KAL   print *,'TODO: Process dp inconsistencies'
+!KAL   call exit(0)
+!KAL
+!KAL
+!KAL
+end program

EnKF-MPI-TOPAZ/Tools/p_obsstats.F90

@@ -0,0 +1,378 @@
+program p_obsstats
+! Computes the EnKF analysis
+
+! For parallelization
+#if defined (QMPI)
+   use qmpi
+   use distribute
+#else
+   use qmpi_fake
+#endif
+   use mod_measurement
+   use mod_sphere_tools
+   use m_get_mod_grid
+   use m_get_mod_nrens
+   use m_uobs
+   use m_obs
+   use m_prep_4_EnKF
+   use m_set_random_seed2
+   use m_parse_blkdat
+   use netcdf
+   implicit none
+   
+   integer nrens                               ! Size of ensemble
+   real, dimension(:,:), allocatable :: modlon,modlat,depths
+
+!Generated variables for EnKF analysis
+!Global Analysis
+   real, allocatable, dimension(:,:) :: S
+   real, allocatable, dimension(:,:) :: E
+   real, allocatable, dimension(:)   :: d, meanD, meanS, RMSD, RMSE, RMSS, &
+      mask_obs
+
+!Local Analysis
+   real radius
+   integer n_obs_local
+   character(len=12) clocal
+
+!Local variables in main program
+   integer iargc
+   integer i,j
+
+!Parallab: Given random seed
+   integer seedsze
+   integer, allocatable ::  putseed(:)
+
+!KAL   real, allocatable, dimension(:,:,:,:) :: subS, X3
+   real(8) rtc, old, time0, time1
+
+!KAL -- just for testing parse_blkdat
+   real :: rdummy
+   integer :: idm, jdm, kdm
+
+   real :: mindx,meandx
+
+
+#if defined(MATLAB)
+!#include </export/fimm/local/Matlab-R14sp3/extern/include/fintrf.h> fimm
+#include </usr/local/Matlab-6.5/extern/include//fintrf.h> 
+   MWPOINTER :: mxCreateNumericMatrix, mxGetPr, mxClassIDFromClassName, matopen,  &
+      mxCreateDoubleMatrix, matPutVariableAsGlobal, mp, pa1
+   integer matputvariable, matclose
+   real*8, dimension(:,:), allocatable :: matio
+   integer :: status
+#endif
+
+   ! Netcdf output
+   integer :: obsdim, var_id,ncid,ierr2
+   character(len=80) :: ncfile
+
+   logical :: ex
+   character(len=20) :: regname
+   integer,parameter :: maxcorners=10
+   real, dimension(maxcorners) :: crnlon, crnlat
+   integer           :: numcorners,nrobsbox
+   integer, dimension(:), allocatable :: pointinbox
+
+
+   integer :: iuobs
+
+   integer :: ios
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Read the characteristics of the assimilation to be carried out.
+
+   if (iargc()/=0) then
+      stop 'usage: obstats [ no argument ] '
+   endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Set a variable random seed
+!//lab   call set_random_seed2
+
+! Remove any randomness in the results for Parallab
+   call random_seed(size=seedsze)
+   allocate(putseed(seedsze))
+   putseed(:)=13
+   call random_seed(put=putseed)
+   deallocate(putseed)
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Get model dimensions - first step on the path to a model-independent EnKF
+   call parse_blkdat('idm   ','integer',rdummy,idm)
+   call parse_blkdat('jdm   ','integer',rdummy,jdm)
+   call parse_blkdat('kdm   ','integer',rdummy,kdm)
+
+! Allocate model grid
+   allocate(modlon(idm,jdm))
+   allocate(modlat(idm,jdm))
+   allocate(depths(idm,jdm))
+   
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Read measurements and store in d
+   if (master) then
+      print*,' '
+      print*,'Start reading files, calling obs_readobs()'
+   end if
+   call obs_readobs
+   if (master) then
+      print '(2a,i6)', obs(1)%id,' Number of obs =',nobs
+      print '(2a,2f6.2)', obs(1)%id,'first obs and var= ',obs(1)%d, obs(1)%var
+      print '(2a,2f6.2)', obs(nobs)%id,'last  obs and var= ',obs(nobs)%d, obs(nobs)%var
+   end if
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Get model grid
+   if (master) then
+      print*,' '
+      print*,'EnKF: Start reading files, get_mod_grid'
+   end if
+   call get_mod_grid(modlon,modlat,depths,mindx,meandx,idm,jdm)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Read ensemble and store in A
+
+   nrens=get_mod_nrens(idm,jdm)
+   if (master) print *,'NR ENS (available) = ',nrens,' !!!!'
+   !call stop_mpi()
+   if (master) then
+      print*,'EnKF: Start calculations of input to the analysis'
+   end if
+
+   allocate(S(nobs, nrens), d(nobs))
+   allocate(meanD(nobs), meanS(nobs))
+
+time0 = rtc()
+
+! KAL -- move ssh stuff in here, as well as reading "observed" variable
+   call uobs_get(obs%id, nobs, .true.)
+   call obs_prepareobs
+   print*, 'Unique obs ', unique_obs(:)
+   call prep_4_EnKF(nrens,d,S,depths,meandx*0.001,idm,jdm,kdm)
+
+   print *,'prep_4_EnKF ferdig'
+
+
+
+! mean innovations 
+
+   ! old code (allegedly wrong - PS)
+   !
+   !meanD(:)=0.
+   !do j=1,nrens
+   !   do i=1,nobs
+   !      meanD(i)=meanD(i)+D(i,j)
+   !   enddo
+   !enddo
+   !meanD(:)=meanD(:)/real(nrens)
+
+   meanD(1 : nobs) = obs(1 : nobs) % d - meanS(1 : nobs)
+
+! Innovation RMS without obs. perturbations
+   allocate(RMSD(nobs))
+   RMSD(:)=0.
+   do i=1,nobs
+      RMSD(i)=RMSD(i)+meanD(i)**2
+   enddo
+   RMSD(:)=sqrt(RMSD(:))
+
+! observation std. deviation
+   allocate(RMSE(nobs))
+   RMSE(:)=0.
+   do j=1,nrens
+      do i=1,nobs
+         RMSE(i)=RMSE(i)+E(i,j)**2
+      enddo
+   enddo
+   RMSE(:)=sqrt(RMSE(:)/real(nrens-1))
+
+! model std. deviation
+   allocate(RMSS(nobs))
+   RMSS(:)=0.
+   do j=1,nrens
+      do i=1,nobs
+         RMSS(i)=RMSS(i)+S(i,j)**2
+      enddo
+   enddo
+   RMSS(:)=sqrt(RMSS(:)/real(nrens-1))
+
+   print *,'obs stats ferdig'
+
+! In case there are more than 1 obs -- order them in this mask
+   allocate(mask_obs(nobs))
+!   nuobs=1
+!   unique_obs(nuobs)=obs(1)%id
+!   do i=1,nobs
+!      if (all(unique_obs(1:nuobs)/=obs(i)%id)) then
+!         nuobs=nuobs+1
+!
+!         if (nuobs>maxnuobs) then
+!            print *, '(obsstats: too many unique obs ids)'
+!            call exit(1)
+!         end if
+!
+!         unique_obs(nuobs)=obs(i)%id
+!      end if
+!   end do
+      
+   do iuobs=1,nuobs
+      where ( obs%id == unique_obs(iuobs) )  mask_obs=iuobs
+   end do
+
+   print *,'obs mask done'
+      
+
+   ! Produce tec fields - should be split into several files/zones if observations
+   ! are of different types
+   open(10,file='innovationstats.tec',status='replace')
+   write(10,*)'TITLE = "innovation statistics"'
+   write(10,*)'VARIABLES = "i-index" "j-index" "lon" "lat" "meaninnov"' // &
+              '"RMSinnov" "stdobs" "stdmodel" "maskobs" '
+   write(10,'(a,i7)')' ZONE  F=BLOCK, I=',nobs
+   write(10,900)(obs(i)%ipiv + obs(i)%a1 + obs(i)%a4,i=1,nobs)
+   write(10,900)(obs(i)%jpiv + obs(i)%a2 + obs(i)%a3,i=1,nobs)
+   write(10,900)(obs(i)%lon                         ,i=1,nobs)
+   write(10,900)(obs(i)%lat                         ,i=1,nobs)
+   write(10,900)(meanD(i)                           ,i=1,nobs)
+   write(10,900)(RMSD (i)                           ,i=1,nobs)
+   write(10,900)(RMSE (i)                           ,i=1,nobs)
+   write(10,900)(RMSS (i)                           ,i=1,nobs)
+   write(10,900)(mask_obs(i)                        ,i=1,nobs)
+   close(10)
+ 900 format(10(1x,e12.5))
+
+#if defined (MATLAB)
+   ! Do the same for matlab -- only partly finished
+   print *,'matlab'
+   allocate(matio (nobs,1))
+   mp=matopen('innovationstats.mat','w')
+
+   matio(:,1)=obs(:)%lon
+   pa1=mxCreateNumericMatrix(nobs,1,mxClassIDFromClassName('double'),0)
+   call mxCopyReal8ToPtr(matio,mxGetPr(pa1),nobs)
+   status = matPutVariable(mp, 'lon', pa1)
+
+   matio(:,1)=obs(:)%lat
+   pa1=mxCreateNumericMatrix(nobs,1,mxClassIDFromClassName('double'),0)
+   call mxCopyReal8ToPtr(matio,mxGetPr(pa1),nobs)
+   status = matPutVariable(mp, 'lat', pa1)
+
+   matio(:,1)=meanD
+   pa1=mxCreateNumericMatrix(nobs,1,mxClassIDFromClassName('double'),0)
+   call mxCopyReal8ToPtr(matio,mxGetPr(pa1),nobs)
+   status = matPutVariable(mp, 'mean_innov', pa1)
+#endif
+
+   ! Netcdf - safest bet
+   ncfile='innovationstats.nc'
+   if (NF90_CREATE(trim(ncfile),NF90_CLOBBER,ncid) /= NF90_NOERR) then
+      print *,'An error occured when opening the netcdf file'
+      stop '(obsstats)'
+   end if
+   ierr2=NF90_DEF_DIM(ncid,'nobs',nobs,obsdim)
+
+   ierr2=NF90_DEF_VAR(ncid,'lon',NF90_Float,obsdim,var_id)
+   ierr2=NF90_ENDDEF(ncid)
+   ierr2=NF90_PUT_VAR(ncid,var_id,obs(:)%lon)
+
+   ierr2=NF90_REDEF(ncid)
+   ierr2=NF90_DEF_VAR(ncid,'lat',NF90_Float,obsdim,var_id)
+   ierr2=NF90_ENDDEF(ncid)
+   ierr2=NF90_PUT_VAR(ncid,var_id,obs(:)%lat)
+
+   ierr2=NF90_REDEF(ncid)
+   ierr2=NF90_DEF_VAR(ncid,'meaninnov',NF90_Float,obsdim,var_id)
+   ierr2=NF90_ENDDEF(ncid)
+   ierr2=NF90_PUT_VAR(ncid,var_id,meanD)
+
+   ierr2=NF90_REDEF(ncid)
+   ierr2=NF90_DEF_VAR(ncid,'RMSinnov',NF90_Float,obsdim,var_id)
+   ierr2=NF90_ENDDEF(ncid)
+   ierr2=NF90_PUT_VAR(ncid,var_id,RMSD)
+
+   ierr2=NF90_REDEF(ncid)
+   ierr2=NF90_DEF_VAR(ncid,'varobs',NF90_Float,obsdim,var_id)
+   ierr2=NF90_ENDDEF(ncid)
+   ierr2=NF90_PUT_VAR(ncid,var_id,RMSE)
+
+   ierr2=NF90_REDEF(ncid)
+   ierr2=NF90_DEF_VAR(ncid,'varmodel',NF90_Float,obsdim,var_id)
+   ierr2=NF90_ENDDEF(ncid)
+   ierr2=NF90_PUT_VAR(ncid,var_id,RMSS)
+
+   ierr2=NF90_REDEF(ncid)
+   ierr2=NF90_DEF_VAR(ncid,'maskobs',NF90_Float,obsdim,var_id)
+   ierr2=NF90_ENDDEF(ncid)
+   ierr2=NF90_PUT_VAR(ncid,var_id,mask_obs)
+
+   ierr2=NF90_CLOSE(ncid)
+
+
+
+! Global stats
+
+   print *,'Global mean innovation      : ',sum(meanD(1 : nobs))/nobs
+   print *,'Global mean innovation RMS  : ',sum(RMSD(1 : nobs))/nobs
+   print *,'Global mean obs    variance : ',sum(RMSE(1 : nobs))/nobs
+   print *,'Global mean model  variance : ',sum(RMSS(1 : nobs))/nobs
+
+
+   ! Regional stats - only if the file below exists
+   inquire(exist=ex,file='EnKF_regstats.in',iostat=ios)
+   if (ios.ne.0) stop 'obsstat: error opening EnKF_regstats.in'
+   if (ex) then
+      allocate(pointinbox(nobs))
+      print *,'Found EnKF_regstats.in - producing regional statistics'
+      open(10,file='EnKF_regstats.in',status='old') 
+
+      do while (ios==0) 
+
+         read(10,'(a)',iostat=ios) regname
+         if (ios/=0) cycle
+         read(10,*,iostat=ios) numcorners
+         print *, 'Region is ', regname, ' and has ', numcorners, ' corners'
+
+         if (numcorners>maxcorners) then
+            print *,'obsstats can only handle ',maxcorners,' corners'
+            call exit(1)
+         end if
+
+         read(10,*,iostat=ios) crnlon(1:numcorners)
+         read(10,*,iostat=ios) crnlat(1:numcorners)
+
+         ! Find points in box
+         pointinbox=0
+         do i=1,nobs
+            if ( inbox(crnlon,crnlat,numcorners,obs(i)%lon,obs(i)%lat)) &
+            pointinbox(i)=1
+         end do
+
+         print *,'Total nobs     :',nobs
+         print *,'Total in testbox:',sum(pointinbox)
+
+         nrobsbox=sum(pointinbox)
+         if (nrobsbox==0) cycle
+
+         print *,trim(regname)//' mean innovation      : ',sum(meanD(1:nobs)*pointinbox(1:nobs))/nrobsbox
+         print *,trim(regname)//' mean innovation RMS  : ',sum(RMSD*pointinbox )/nrobsbox
+         print *,trim(regname)//' mean obs    variance : ',sum(RMSE*pointinbox )/nrobsbox
+         print *,trim(regname)//' mean model  variance : ',sum(RMSS*pointinbox )/nrobsbox
+
+      end do
+
+      close (10)
+
+   else
+      print *,'EnKF_regstats.in not found - skipping regional statistics'
+   end if
+
+
+  print*,'obsstats: Finished'
+
+
+
+
+end program 
+

EnKF-MPI-TOPAZ/Tools/p_oldtonewobs.F90

@@ -0,0 +1,71 @@
+program oldtonewobs
+   use mod_measurement_oldnew
+   implicit none
+
+   type (measurement_old) :: oldobs
+   type (measurement_new) :: newobs
+
+   integer :: reclold,reclnew
+   integer :: iobs
+   integer :: iosin, iosout
+   logical :: ex
+
+
+   ! copy old obs 
+   inquire(exist=ex,file='observations.uf')
+   if (ex) then
+      call system("cp observations.uf old_observations.uf")
+   else
+      print *,'observations.uf does not exist'
+      call exit(1)
+   end if
+
+   ! Open old and new obs files
+   inquire(iolength=reclold) oldobs
+   inquire(iolength=reclnew) newobs
+   open(10, file='old_observations.uf',status='old',recl=reclold,access='direct')
+   open(11, file='new_observations.uf',status='replace',recl=reclnew,access='direct')
+
+   iosin=0
+   iosout=0
+   iobs=1
+   do while (iosin==0 .and. iosout==0)
+
+      read(10,rec=iobs,iostat=iosin) oldobs
+
+      if (iosin==0) then
+
+         call oldtonew(oldobs,newobs)
+
+         write(11,rec=iobs,iostat=iosout) newobs
+
+         !print *,newobs%ipiv,newobs%jpiv
+
+         iobs=iobs+1
+
+         if (iosout/=0) then
+            print *,'Error when writing to new obs'
+            print *,'(oldtonewobs)'
+            call exit(1)
+         end if
+      end if
+
+   end do
+   close(10)
+   close(11)
+
+   print *,'Processed ',iobs-1,' observations'
+
+
+
+
+   
+
+
+
+
+
+
+
+end program  oldtonewobs
+

EnKF-MPI-TOPAZ/Tools/p_testrandom.F90

@@ -0,0 +1,38 @@
+program testrandom
+! checks random numbers
+
+! For parallelization
+   use m_set_random_seed2
+   implicit none
+   integer seedsze, i, maxnb
+   real, allocatable :: putseed(:)
+   real rand, frac
+   integer histo(10)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Set a variable random seed
+   call set_random_seed2
+
+   maxnb=1000000
+! Remove any randomness in the results for Parallab
+!   call random_seed(size=seedsze)
+!   allocate(putseed(seedsze))
+!   putseed(:)=13
+!   call random_seed(put=putseed)
+!   deallocate(putseed)
+
+histo=0
+do i=1,maxnb
+   call random_number(rand)
+   do i=1,10 
+     frac=1./float(i)
+     if (rand>frac-0.1 .and. rand<frac) histo(i)=histo(i)+1 
+   enddo
+
+!   if (mod(i,100)==0) then 
+!      print *, rand 
+!   endif
+enddo
+print *,histo(:)/float(maxnb)
+
+end program

EnKF-MPI-TOPAZ/Tools/setupanalysis.sh

@@ -0,0 +1,41 @@
+#!/bin/bash
+
+#KAL -- This script sets up the forecast for the EnKF. Input 
+#KAL -- is the "base" of the analysis file name
+
+[ $# -ne 2 ] && { echo "No base file name and target supplied" ; exit 1 ;}
+
+# HYCOM files
+if ! ls ${1}[0-9][0-9][0-9].[ab] > /dev/null  ; then
+   echo "Could not find files with base $1"
+   exit 1
+fi
+#ls ${1}[0-9][0-9][0-9].[ab] 
+
+
+
+for i in ${1}[0-9][0-9][0-9].[ab] ; do
+
+   numpart=$(echo $i | sed "s/.*$1//" | sed "s/\..*//")
+   abpart=$(echo $i | sed "s/.*\.//")
+   #echo $i $numpart $abpart
+
+   if [ $numpart -gt 1 ] ; then
+      #echo "yes"
+      tailpart="_mem$numpart.$abpart"
+   else
+      tailpart=".$abpart"
+   fi
+
+
+   newfile=${2}$tailpart
+   echo "$newfile -> $i"
+   ln -sf $i $newfile  
+done
+
+# Ice file
+if [ -f ${1}ICE.uf ] ; then
+   finalname=${2}ICE.uf
+   echo "$finalname -- >  ${1}ICE.uf "
+   ln -sf ${1}ICE.uf  $finalname ; 
+fi

EnKF-MPI-TOPAZ/Tools/setupforecast.sh

@@ -0,0 +1,33 @@
+#!/bin/bash
+
+#KAL -- This script sets up the forecast for the EnKF. Input 
+#KAL -- is the "base" of the analysis file name
+
+[ $# -ne 1 ] && { echo "No base file name supplied" ; exit 1 ;}
+
+# HYCOM files
+if ! ls ${1}.[ab] > /dev/null || ! ls ${1}_mem???.[ab] > /dev/null  ; then
+   echo "Could not find files with base $1"
+   exit 1
+fi
+
+for i in ${1}.[ab] ${1}_mem???.[ab] ; do
+   tailpart1=$(echo $i | tail -c9 )
+   tailpart2=$(echo $i | tail -c9 | cut -c1-3)
+   post=$(echo $i | sed "s/.*\.//")
+
+   if [ ! "$tailpart2" == "mem" ] ; then
+      tailpart1="mem001.${post}"
+   fi
+
+   finalname=$( echo $tailpart1 | sed "s/mem/forecast/")
+   echo "$finalname -- > $i"
+   ln -s $i $finalname  
+done
+
+# Ice file
+if [ -f ${1}ICE.uf ] ; then
+   finalname=forecastICE.uf
+   echo "$finalname -- > ${1}ICE.uf"
+   ln -s ${1}ICE.uf  forecastICE.uf ; 
+fi

EnKF-MPI-TOPAZ/analysisfields.in

@@ -0,0 +1,65 @@
+a_i_htc1        0 0 1
+a_i_htc2        0 0 1
+a_i_htc3        0 0 1
+a_i_htc4        0 0 1
+a_i_htc5        0 0 1
+oa_i_htc1       0 0 1
+oa_i_htc2       0 0 1
+oa_i_htc3       0 0 1
+oa_i_htc4       0 0 1
+oa_i_htc5       0 0 1
+smv_i_htc1      0 0 1
+smv_i_htc2      0 0 1
+smv_i_htc3      0 0 1
+smv_i_htc4      0 0 1
+smv_i_htc5      0 0 1
+snwice_mass     0 0 1
+snwice_mass_b   0 0 1
+tempt_il1_htc1  0 0 1
+tempt_il1_htc2  0 0 1
+tempt_il1_htc3  0 0 1
+tempt_il1_htc4  0 0 1
+tempt_il1_htc5  0 0 1
+tempt_il2_htc1  0 0 1
+tempt_il2_htc2  0 0 1
+tempt_il2_htc3  0 0 1
+tempt_il2_htc4  0 0 1
+tempt_il2_htc5  0 0 1
+tempt_sl1_htc1  0 0 1
+tempt_sl1_htc2  0 0 1
+tempt_sl1_htc3  0 0 1
+tempt_sl1_htc4  0 0 1
+tempt_sl1_htc5  0 0 1
+u_ice           0 0 1
+v_i_htc1        0 0 1
+v_i_htc2        0 0 1
+v_i_htc3        0 0 1
+v_i_htc4        0 0 1
+v_i_htc5        0 0 1
+v_ice           0 0 1
+v_s_htc1        0 0 1
+v_s_htc2        0 0 1
+v_s_htc3        0 0 1
+v_s_htc4        0 0 1
+v_s_htc5        0 0 1
+en              1 75 2
+hdivb           1 75 2
+hdivn           1 75 2
+rhop            1 75 2
+rotb            1 75 2
+rotn            1 75 2
+sb              1 75 2
+sn              1 75 2
+sshb            0 0 2
+ssh_m           0 0 2
+sshn            0 0 2
+sss_m           0 0 2
+sst_m           0 0 2
+ssu_m           0 0 2
+ssv_m           0 0 2
+tb              1 75 2
+tn              1 75 2
+ub              1 75 2
+un              1 75 2
+vb              1 75 2
+vn              1 75 2

EnKF-MPI-TOPAZ/cfortran.h

@@ -0,0 +1,2422 @@
+/* cfortran.h  4.4 */
+/* http://www-zeus.desy.de/~burow/cfortran/                   */
+/* Burkhard Burow  burow@desy.de                 1990 - 2002. */
+
+#ifndef __CFORTRAN_LOADED
+#define __CFORTRAN_LOADED
+
+/* 
+   THIS FILE IS PROPERTY OF BURKHARD BUROW. IF YOU ARE USING THIS FILE YOU
+   SHOULD ALSO HAVE ACCESS TO CFORTRAN.DOC WHICH PROVIDES TERMS FOR USING,
+   MODIFYING, COPYING AND DISTRIBUTING THE CFORTRAN.H PACKAGE.
+*/
+
+/* The following modifications were made by the authors of CFITSIO or by me. 
+ * I've flagged them below with "(CFITSIO)" or "(KMCCARTY)".
+ * PDW = Peter Wilson
+ * DM  = Doug Mink
+ * LEB = ??
+ * -- Kevin McCarty, for Debian (11/29/2003) */
+
+/*******
+   Modifications:
+      Oct 1997: Changed symbol name extname to appendus (PDW/HSTX)
+                (Conflicted with a common variable name in FTOOLS)
+      Nov 1997: If g77Fortran defined, also define f2cFortran (PDW/HSTX)
+      Feb 1998: Let VMS see the NUM_ELEMS code. Lets programs treat
+                single strings as vectors with single elements
+      Nov 1999: If macintoxh defined, also define f2cfortran (for Mac OS-X)
+      Apr 2000: If WIN32 defined, also define PowerStationFortran and
+                VISUAL_CPLUSPLUS (Visual C++)
+      Jun 2000: If __GNUC__ and linux defined, also define f2cFortran
+                (linux/gcc environment detection)
+      Apr 2002: If __CYGWIN__ is defined, also define f2cFortran
+      Nov 2002: If __APPLE__ defined, also define f2cfortran (for Mac OS-X)
+
+      Nov 2003: If __INTEL_COMPILER or INTEL_COMPILER defined, also define
+                f2cFortran (KMCCARTY)
+ *******/
+
+/* 
+  Avoid symbols already used by compilers and system *.h:
+  __ - OSF1 zukal06 V3.0 347 alpha, cc -c -std1 cfortest.c
+
+ */
+
+
+/* First prepare for the C compiler. */
+
+#ifndef ANSI_C_preprocessor /* i.e. user can override. */
+#ifdef __CF__KnR
+#define ANSI_C_preprocessor 0
+#else
+#ifdef __STDC__
+#define ANSI_C_preprocessor 1
+#else
+#define _cfleft             1
+#define _cfright 
+#define _cfleft_cfright     0
+#define ANSI_C_preprocessor _cfleft/**/_cfright
+#endif
+#endif
+#endif
+
+#if ANSI_C_preprocessor
+#define _0(A,B)   A##B
+#define  _(A,B)   _0(A,B)  /* see cat,xcat of K&R ANSI C p. 231 */
+#define _2(A,B)   A##B     /* K&R ANSI C p.230: .. identifier is not replaced */
+#define _3(A,B,C) _(A,_(B,C))
+#else                      /* if it turns up again during rescanning.         */
+#define  _(A,B)   A/**/B
+#define _2(A,B)   A/**/B
+#define _3(A,B,C) A/**/B/**/C
+#endif
+
+#if (defined(vax)&&defined(unix)) || (defined(__vax__)&&defined(__unix__))
+#define VAXUltrix
+#endif
+
+#include <stdio.h>     /* NULL [in all machines stdio.h]                      */
+#include <string.h>    /* strlen, memset, memcpy, memchr.                     */
+#if !( defined(VAXUltrix) || defined(sun) || (defined(apollo)&&!defined(__STDCPP__)) )
+#include <stdlib.h>    /* malloc,free                                         */
+#else
+#include <malloc.h>    /* Had to be removed for DomainOS h105 10.4 sys5.3 425t*/
+#ifdef apollo
+#define __CF__APOLLO67 /* __STDCPP__ is in Apollo 6.8 (i.e. ANSI) and onwards */
+#endif
+#endif
+
+#if !defined(__GNUC__) && !defined(__sun) && (defined(sun)||defined(VAXUltrix)||defined(lynx))
+#define __CF__KnR     /* Sun, LynxOS and VAX Ultrix cc only supports K&R.     */
+                      /* Manually define __CF__KnR for HP if desired/required.*/
+#endif                /*       i.e. We will generate Kernighan and Ritchie C. */
+/* Note that you may define __CF__KnR before #include cfortran.h, in order to
+generate K&R C instead of the default ANSI C. The differences are mainly in the
+function prototypes and declarations. All machines, except the Apollo, work
+with either style. The Apollo's argument promotion rules require ANSI or use of
+the obsolete std_$call which we have not implemented here. Hence on the Apollo,
+only C calling FORTRAN subroutines will work using K&R style.*/
+
+
+/* Remainder of cfortran.h depends on the Fortran compiler. */
+
+/* 11/29/2003 (KMCCARTY): add *INTEL_COMPILER symbols here */
+#if defined(CLIPPERFortran) || defined(pgiFortran) || defined(__INTEL_COMPILER) || defined(INTEL_COMPILER)
+#define f2cFortran
+#endif
+
+/* VAX/VMS does not let us \-split long #if lines. */ 
+/* Split #if into 2 because some HP-UX can't handle long #if */
+#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran))
+#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran))
+/* If no Fortran compiler is given, we choose one for the machines we know.   */
+#if defined(lynx) || defined(VAXUltrix)
+#define f2cFortran    /* Lynx:      Only support f2c at the moment.
+                         VAXUltrix: f77 behaves like f2c.
+                           Support f2c or f77 with gcc, vcc with f2c. 
+                           f77 with vcc works, missing link magic for f77 I/O.*/
+#endif
+/* 04/13/00 DM (CFITSIO): Add these lines for NT */
+/*   with PowerStationFortran and and Visual C++ */
+#if defined(WIN32) && !defined(__CYGWIN__)
+#define PowerStationFortran   
+#define VISUAL_CPLUSPLUS
+#endif
+#if defined(g77Fortran)                        /* 11/03/97 PDW (CFITSIO) */
+#define f2cFortran
+#endif
+#if        defined(__CYGWIN__)                 /* 04/11/02 LEB (CFITSIO) */
+#define       f2cFortran 
+#endif
+/* commented out -- PS
+ * #if        defined(__GNUC__) && defined(linux)
+ * #define       f2cFortran 
+ * #error f2cFortran:5
+ * #endif
+ */
+#if defined(macintosh)                         /* 11/1999 (CFITSIO) */
+#define f2cFortran
+#endif
+#if defined(__APPLE__)                         /* 11/2002 (CFITSIO) */
+#define f2cFortran
+#endif
+#if defined(g95Fortran)                        /* 01/04/05 PS */
+#define f2cFortran
+#endif
+#if defined(__hpux)             /* 921107: Use __hpux instead of __hp9000s300 */
+#define       hpuxFortran       /*         Should also allow hp9000s7/800 use.*/
+#endif
+#if       defined(apollo)
+#define           apolloFortran /* __CF__APOLLO67 also defines some behavior. */
+#endif
+#if          defined(sun) || defined(__sun) 
+#define              sunFortran
+#endif
+#if       defined(_IBMR2)
+#define            IBMR2Fortran
+#endif
+#if        defined(_CRAY)
+#define             CRAYFortran /*       _CRAYT3E also defines some behavior. */
+#endif
+#if        defined(_SX)
+#define               SXFortran
+#endif
+#if         defined(mips) || defined(__mips)
+#define             mipsFortran
+#endif
+#if          defined(vms) || defined(__vms)
+#define              vmsFortran
+#endif
+#if      defined(__alpha) && defined(__unix__)
+#define              DECFortran
+#endif
+#if   defined(__convex__)
+#define           CONVEXFortran
+#endif
+#if   defined(VISUAL_CPLUSPLUS)
+#define     PowerStationFortran
+#endif
+#endif /* ...Fortran */
+#endif /* ...Fortran */
+
+/* Split #if into 2 because some HP-UX can't handle long #if */
+#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran))
+#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran))
+/* If your compiler barfs on ' #error', replace # with the trigraph for #     */
+ #error "cfortran.h:  Can't find your environment among:\
+    - GNU gcc (g77) on Linux.                                            \
+    - MIPS cc and f77 2.0. (e.g. Silicon Graphics, DECstations, ...)     \
+    - IBM AIX XL C and FORTRAN Compiler/6000 Version 01.01.0000.0000     \
+    - VAX   VMS CC 3.1 and FORTRAN 5.4.                                  \
+    - Alpha VMS DEC C 1.3 and DEC FORTRAN 6.0.                           \
+    - Alpha OSF DEC C and DEC Fortran for OSF/1 AXP Version 1.2          \
+    - Apollo DomainOS 10.2 (sys5.3) with f77 10.7 and cc 6.7.            \
+    - CRAY                                                               \
+    - NEC SX-4 SUPER-UX                                                  \
+    - CONVEX                                                             \
+    - Sun                                                                \
+    - PowerStation Fortran with Visual C++                               \
+    - HP9000s300/s700/s800 Latest test with: HP-UX A.08.07 A 9000/730    \
+    - LynxOS: cc or gcc with f2c.                                        \
+    - VAXUltrix: vcc,cc or gcc with f2c. gcc or cc with f77.             \
+    -            f77 with vcc works; but missing link magic for f77 I/O. \
+    -            NO fort. None of gcc, cc or vcc generate required names.\
+    - f2c    : Use #define    f2cFortran, or cc -Df2cFortran             \
+    - NAG f90: Use #define NAGf90Fortran, or cc -DNAGf90Fortran          \
+    - Absoft UNIX F77: Use #define AbsoftUNIXFortran or cc -DAbsoftUNIXFortran \
+    - Absoft Pro Fortran: Use #define AbsoftProFortran \
+    - Portland Group Fortran: Use #define pgiFortran \
+    - Intel Fortran: Use #define INTEL_COMPILER"
+/* Compiler must throw us out at this point! */
+#endif
+#endif
+
+
+#if defined(VAXC) && !defined(__VAXC)
+#define OLD_VAXC
+#pragma nostandard                       /* Prevent %CC-I-PARAMNOTUSED.       */
+#endif
+
+/* Throughout cfortran.h we use: UN = Uppercase Name.  LN = Lowercase Name.   */
+
+/* "extname" changed to "appendus" below (CFITSIO) */
+#if defined(f2cFortran) || defined(NAGf90Fortran) || defined(DECFortran) || defined(mipsFortran) || defined(apolloFortran) || defined(sunFortran) || defined(CONVEXFortran) || defined(SXFortran) || defined(appendus)
+#define CFC_(UN,LN)            _(LN,_)      /* Lowercase FORTRAN symbols.     */
+#define orig_fcallsc(UN,LN)    CFC_(UN,LN)
+#else 
+#if defined(CRAYFortran) || defined(PowerStationFortran) || defined(AbsoftProFortran)
+#ifdef _CRAY          /* (UN), not UN, circumvents CRAY preprocessor bug.     */
+#define CFC_(UN,LN)            (UN)         /* Uppercase FORTRAN symbols.     */
+#else                 /* At least VISUAL_CPLUSPLUS barfs on (UN), so need UN. */
+#define CFC_(UN,LN)            UN           /* Uppercase FORTRAN symbols.     */
+#endif
+#define orig_fcallsc(UN,LN)    CFC_(UN,LN)  /* CRAY insists on arg.'s here.   */
+#else  /* For following machines one may wish to change the fcallsc default.  */
+#define CF_SAME_NAMESPACE
+#ifdef vmsFortran
+#define CFC_(UN,LN)            LN           /* Either case FORTRAN symbols.   */
+     /* BUT we usually use UN for C macro to FORTRAN routines, so use LN here,*/
+     /* because VAX/VMS doesn't do recursive macros.                          */
+#define orig_fcallsc(UN,LN)    UN
+#else      /* HP-UX without +ppu or IBMR2 without -qextname. NOT reccomended. */
+#define CFC_(UN,LN)            LN           /* Lowercase FORTRAN symbols.     */
+#define orig_fcallsc(UN,LN)    CFC_(UN,LN)
+#endif /*  vmsFortran */
+#endif /* CRAYFortran PowerStationFortran */
+#endif /* ....Fortran */
+
+#define fcallsc(UN,LN)               orig_fcallsc(UN,LN)
+#define preface_fcallsc(P,p,UN,LN)   CFC_(_(P,UN),_(p,LN))
+#define  append_fcallsc(P,p,UN,LN)   CFC_(_(UN,P),_(LN,p))
+
+#define C_FUNCTION(UN,LN)            fcallsc(UN,LN)      
+#define FORTRAN_FUNCTION(UN,LN)      CFC_(UN,LN)
+
+#ifndef COMMON_BLOCK
+#ifndef CONVEXFortran
+#ifndef CLIPPERFortran
+#if     !(defined(AbsoftUNIXFortran)||defined(AbsoftProFortran))
+#define COMMON_BLOCK(UN,LN)          CFC_(UN,LN)
+#else
+#define COMMON_BLOCK(UN,LN)          _(_C,LN)
+#endif  /* AbsoftUNIXFortran or AbsoftProFortran */
+#else
+#define COMMON_BLOCK(UN,LN)          _(LN,__)
+#endif  /* CLIPPERFortran */
+#else
+#define COMMON_BLOCK(UN,LN)          _3(_,LN,_)
+#endif  /* CONVEXFortran */
+#endif  /* COMMON_BLOCK */
+
+#ifndef DOUBLE_PRECISION
+#if defined(CRAYFortran) && !defined(_CRAYT3E)
+#define DOUBLE_PRECISION long double
+#else
+#define DOUBLE_PRECISION double
+#endif
+#endif
+
+#ifndef FORTRAN_REAL
+#if defined(CRAYFortran) &&  defined(_CRAYT3E)
+#define FORTRAN_REAL double
+#else
+#define FORTRAN_REAL float
+#endif
+#endif
+
+#ifdef CRAYFortran
+#ifdef _CRAY
+#include <fortran.h>
+#else
+#include "fortran.h"  /* i.e. if crosscompiling assume user has file. */
+#endif
+#define FLOATVVVVVVV_cfPP (FORTRAN_REAL *)   /* Used for C calls FORTRAN.     */
+/* CRAY's double==float but CRAY says pointers to doubles and floats are diff.*/
+#define VOIDP  (void *)  /* When FORTRAN calls C, we don't know if C routine 
+                            arg.'s have been declared float *, or double *.   */
+#else
+#define FLOATVVVVVVV_cfPP
+#define VOIDP
+#endif
+
+#ifdef vmsFortran
+#if    defined(vms) || defined(__vms)
+#include <descrip.h>
+#else
+#include "descrip.h"  /* i.e. if crosscompiling assume user has file. */
+#endif
+#endif
+
+#ifdef sunFortran
+#if defined(sun) || defined(__sun)
+#include <math.h>     /* Sun's FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT.  */
+#else
+#include "math.h"     /* i.e. if crosscompiling assume user has file. */
+#endif
+/* At least starting with the default C compiler SC3.0.1 of SunOS 5.3,
+ * FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT are not required and not in
+ * <math.h>, since sun C no longer promotes C float return values to doubles.
+ * Therefore, only use them if defined.
+ * Even if gcc is being used, assume that it exhibits the Sun C compiler
+ * behavior in order to be able to use *.o from the Sun C compiler.
+ * i.e. If FLOATFUNCTIONTYPE, etc. are in math.h, they required by gcc.
+ */
+#endif
+
+#ifndef apolloFortran
+/* "extern" removed (CFITSIO) */
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) /* extern */ DEFINITION NAME
+#define CF_NULL_PROTO
+#else                                         /* HP doesn't understand #elif. */
+/* Without ANSI prototyping, Apollo promotes float functions to double.    */
+/* Note that VAX/VMS, IBM, Mips choke on 'type function(...);' prototypes. */
+#define CF_NULL_PROTO ...
+#ifndef __CF__APOLLO67
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) \
+ DEFINITION NAME __attribute((__section(NAME)))
+#else
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) \
+ DEFINITION NAME #attribute[section(NAME)]
+#endif
+#endif
+
+#ifdef __cplusplus
+#undef  CF_NULL_PROTO
+#define CF_NULL_PROTO  ...
+#endif
+
+
+#ifndef USE_NEW_DELETE
+#ifdef __cplusplus
+#define USE_NEW_DELETE 1
+#else
+#define USE_NEW_DELETE 0
+#endif
+#endif
+#if USE_NEW_DELETE
+#define _cf_malloc(N) new char[N]
+#define _cf_free(P)   delete[] P
+#else
+#define _cf_malloc(N) (char *)malloc(N)
+#define _cf_free(P)   free(P)
+#endif
+
+#ifdef mipsFortran
+#define CF_DECLARE_GETARG         int f77argc; char **f77argv
+#define CF_SET_GETARG(ARGC,ARGV)  f77argc = ARGC; f77argv = ARGV
+#else
+#define CF_DECLARE_GETARG
+#define CF_SET_GETARG(ARGC,ARGV)
+#endif
+
+#ifdef OLD_VAXC                          /* Allow %CC-I-PARAMNOTUSED.         */
+#pragma standard                         
+#endif
+
+#define AcfCOMMA ,
+#define AcfCOLON ;
+
+/*-------------------------------------------------------------------------*/
+
+/*               UTILITIES USED WITHIN CFORTRAN.H                          */
+
+#define _cfMIN(A,B) (A<B?A:B)
+
+/* 970211 - XIX.145:
+   firstindexlength  - better name is all_but_last_index_lengths
+   secondindexlength - better name is         last_index_length
+ */
+#define  firstindexlength(A) (sizeof(A[0])==1 ? 1 : (sizeof(A) / sizeof(A[0])) )
+#define secondindexlength(A) (sizeof(A[0])==1 ?      sizeof(A) : sizeof(A[0])  )
+
+/* Behavior of FORTRAN LOGICAL. All machines' LOGICAL is same size as C's int.
+Conversion is automatic except for arrays which require F2CLOGICALV/C2FLOGICALV.
+f2c, MIPS f77 [DECstation, SGI], VAX Ultrix f77,
+HP-UX f77                                        : as in C.
+VAX/VMS FORTRAN, VAX Ultrix fort,
+Absoft Unix Fortran, IBM RS/6000 xlf             : LS Bit = 0/1 = TRUE/FALSE.
+Apollo                                           : neg.   = TRUE, else FALSE. 
+[Apollo accepts -1 as TRUE for function values, but NOT all other neg. values.]
+[DECFortran for Ultrix RISC is also called f77 but is the same as VAX/VMS.]   
+[MIPS f77 treats .eqv./.neqv. as .eq./.ne. and hence requires LOGICAL_STRICT.]*/
+
+#if defined(NAGf90Fortran) || defined(f2cFortran) || defined(mipsFortran) || defined(PowerStationFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran) || defined(SXFortran)
+/* SX/PowerStationFortran have 0 and 1 defined, others are neither T nor F.   */
+/* hpuxFortran800 has 0 and 0x01000000 defined. Others are unknown.           */
+#define LOGICAL_STRICT      /* Other Fortran have .eqv./.neqv. == .eq./.ne.   */
+#endif
+
+#define C2FLOGICALV(A,I) \
+ do {int __i; for(__i=0;__i<I;__i++) A[__i]=C2FLOGICAL(A[__i]); } while (0)
+#define F2CLOGICALV(A,I) \
+ do {int __i; for(__i=0;__i<I;__i++) A[__i]=F2CLOGICAL(A[__i]); } while (0)
+
+#if defined(apolloFortran)
+#define C2FLOGICAL(L) ((L)?-1:(L)&~((unsigned)1<<sizeof(int)*8-1))
+#define F2CLOGICAL(L) ((L)<0?(L):0) 
+#else
+#if defined(CRAYFortran)
+#define C2FLOGICAL(L) _btol(L)
+#define F2CLOGICAL(L) _ltob(&(L))     /* Strangely _ltob() expects a pointer. */
+#else
+#if defined(IBMR2Fortran) || defined(vmsFortran) || defined(DECFortran) || defined(AbsoftUNIXFortran)
+/* How come no AbsoftProFortran ? */
+#define C2FLOGICAL(L) ((L)?(L)|1:(L)&~(int)1)
+#define F2CLOGICAL(L) ((L)&1?(L):0)
+#else
+#if defined(CONVEXFortran)
+#define C2FLOGICAL(L) ((L) ? ~0 : 0 )
+#define F2CLOGICAL(L) (L)
+#else   /* others evaluate LOGICALs as for C. */
+#define C2FLOGICAL(L) (L)
+#define F2CLOGICAL(L) (L)
+#ifndef LOGICAL_STRICT
+#undef  C2FLOGICALV
+#undef  F2CLOGICALV
+#define C2FLOGICALV(A,I)
+#define F2CLOGICALV(A,I)
+#endif  /* LOGICAL_STRICT                     */
+#endif  /* CONVEXFortran || All Others        */
+#endif  /* IBMR2Fortran vmsFortran DECFortran AbsoftUNIXFortran */
+#endif  /* CRAYFortran                        */
+#endif  /* apolloFortran                      */
+
+/* 970514 - In addition to CRAY, there may be other machines
+            for which LOGICAL_STRICT makes no sense. */
+#if defined(LOGICAL_STRICT) && !defined(CRAYFortran)
+/* Force C2FLOGICAL to generate only the values for either .TRUE. or .FALSE.
+   SX/PowerStationFortran only have 0 and 1 defined.
+   Elsewhere, only needed if you want to do:
+     logical lvariable
+     if (lvariable .eq.  .true.) then       ! (1)
+   instead of
+     if (lvariable .eqv. .true.) then       ! (2)
+   - (1) may not even be FORTRAN/77 and that Apollo's f77 and IBM's xlf
+     refuse to compile (1), so you are probably well advised to stay away from 
+     (1) and from LOGICAL_STRICT.
+   - You pay a (slight) performance penalty for using LOGICAL_STRICT. */
+#undef  C2FLOGICAL
+#ifdef hpuxFortran800
+#define C2FLOGICAL(L) ((L)?0x01000000:0)
+#else
+#if defined(apolloFortran) || defined(vmsFortran) || defined(DECFortran)
+#define C2FLOGICAL(L) ((L)?-1:0) /* These machines use -1/0 for .true./.false.*/
+#else
+#define C2FLOGICAL(L) ((L)? 1:0) /* All others     use +1/0 for .true./.false.*/
+#endif
+#endif
+#endif /* LOGICAL_STRICT */
+
+/* Convert a vector of C strings into FORTRAN strings. */
+#ifndef __CF__KnR
+static char *c2fstrv(char* cstr, char *fstr, int elem_len, int sizeofcstr)
+#else
+static char *c2fstrv(      cstr,       fstr,     elem_len,     sizeofcstr)
+                     char* cstr; char *fstr; int elem_len; int sizeofcstr;
+#endif
+{ int i,j;
+/* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
+   Useful size of string must be the same in both languages. */
+for (i=0; i<sizeofcstr/elem_len; i++) {
+  for (j=1; j<elem_len && *cstr; j++) *fstr++ = *cstr++;
+  cstr += 1+elem_len-j;
+  for (; j<elem_len; j++) *fstr++ = ' ';
+} /* 95109 - Seems to be returning the original fstr. */
+return fstr-sizeofcstr+sizeofcstr/elem_len; }
+
+/* Convert a vector of FORTRAN strings into C strings. */
+#ifndef __CF__KnR
+static char *f2cstrv(char *fstr, char* cstr, int elem_len, int sizeofcstr)
+#else
+static char *f2cstrv(      fstr,       cstr,     elem_len,     sizeofcstr)
+                     char *fstr; char* cstr; int elem_len; int sizeofcstr; 
+#endif
+{ int i,j;
+/* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
+   Useful size of string must be the same in both languages. */
+cstr += sizeofcstr;
+fstr += sizeofcstr - sizeofcstr/elem_len;
+for (i=0; i<sizeofcstr/elem_len; i++) {
+  *--cstr = '\0';
+  for (j=1; j<elem_len; j++) *--cstr = *--fstr;
+} return cstr; }
+
+/* kill the trailing char t's in string s. */
+#ifndef __CF__KnR
+static char *kill_trailing(char *s, char t)
+#else
+static char *kill_trailing(      s,      t) char *s; char t;
+#endif
+{char *e; 
+e = s + strlen(s);
+if (e>s) {                           /* Need this to handle NULL string.*/
+  while (e>s && *--e==t);            /* Don't follow t's past beginning. */
+  e[*e==t?0:1] = '\0';               /* Handle s[0]=t correctly.       */
+} return s; }
+
+/* kill_trailingn(s,t,e) will kill the trailing t's in string s. e normally 
+points to the terminating '\0' of s, but may actually point to anywhere in s.
+s's new '\0' will be placed at e or earlier in order to remove any trailing t's.
+If e<s string s is left unchanged. */ 
+#ifndef __CF__KnR
+static char *kill_trailingn(char *s, char t, char *e)
+#else
+static char *kill_trailingn(      s,      t,       e) char *s; char t; char *e;
+#endif
+{ 
+if (e==s) *e = '\0';                 /* Kill the string makes sense here.*/
+else if (e>s) {                      /* Watch out for neg. length string.*/
+  while (e>s && *--e==t);            /* Don't follow t's past beginning. */
+  e[*e==t?0:1] = '\0';               /* Handle s[0]=t correctly.       */
+} return s; }
+
+/* Note the following assumes that any element which has t's to be chopped off,
+does indeed fill the entire element. */
+#ifndef __CF__KnR
+static char *vkill_trailing(char* cstr, int elem_len, int sizeofcstr, char t)
+#else
+static char *vkill_trailing(      cstr,     elem_len,     sizeofcstr,      t)
+                            char* cstr; int elem_len; int sizeofcstr; char t;
+#endif
+{ int i;
+for (i=0; i<sizeofcstr/elem_len; i++) /* elem_len includes \0 for C strings. */
+  kill_trailingn(cstr+elem_len*i,t,cstr+elem_len*(i+1)-1);
+return cstr; }
+
+#ifdef vmsFortran
+typedef struct dsc$descriptor_s fstring;
+#define DSC$DESCRIPTOR_A(DIMCT)  		                               \
+struct {                                                                       \
+  unsigned short dsc$w_length;	        unsigned char	 dsc$b_dtype;	       \
+  unsigned char	 dsc$b_class;	                 char	*dsc$a_pointer;	       \
+           char	 dsc$b_scale;	        unsigned char	 dsc$b_digits;         \
+  struct {                                                                     \
+    unsigned		       : 3;	  unsigned dsc$v_fl_binscale : 1;      \
+    unsigned dsc$v_fl_redim    : 1;       unsigned dsc$v_fl_column   : 1;      \
+    unsigned dsc$v_fl_coeff    : 1;       unsigned dsc$v_fl_bounds   : 1;      \
+  } dsc$b_aflags;	                                                       \
+  unsigned char	 dsc$b_dimct;	        unsigned long	 dsc$l_arsize;	       \
+           char	*dsc$a_a0;	                 long	 dsc$l_m [DIMCT];      \
+  struct {                                                                     \
+    long dsc$l_l;                         long dsc$l_u;                        \
+  } dsc$bounds [DIMCT];                                                        \
+}
+typedef DSC$DESCRIPTOR_A(1) fstringvector;
+/*typedef DSC$DESCRIPTOR_A(2) fstringarrarr;
+  typedef DSC$DESCRIPTOR_A(3) fstringarrarrarr;*/
+#define initfstr(F,C,ELEMNO,ELEMLEN)                                           \
+( (F).dsc$l_arsize=  ( (F).dsc$w_length                        =(ELEMLEN) )    \
+                    *( (F).dsc$l_m[0]=(F).dsc$bounds[0].dsc$l_u=(ELEMNO)  ),   \
+  (F).dsc$a_a0    =  ( (F).dsc$a_pointer=(C) ) - (F).dsc$w_length          ,(F))
+
+#endif      /* PDW: 2/10/98 (CFITSIO) -- Let VMS see NUM_ELEMS definitions */
+#define _NUM_ELEMS      -1
+#define _NUM_ELEM_ARG   -2
+#define NUM_ELEMS(A)    A,_NUM_ELEMS
+#define NUM_ELEM_ARG(B) *_2(A,B),_NUM_ELEM_ARG
+#define TERM_CHARS(A,B) A,B
+#ifndef __CF__KnR
+static int num_elem(char *strv, unsigned elem_len, int term_char, int num_term)
+#else
+static int num_elem(      strv,          elem_len,     term_char,     num_term)
+                    char *strv; unsigned elem_len; int term_char; int num_term;
+#endif
+/* elem_len is the number of characters in each element of strv, the FORTRAN
+vector of strings. The last element of the vector must begin with at least
+num_term term_char characters, so that this routine can determine how 
+many elements are in the vector. */
+{
+unsigned num,i;
+if (num_term == _NUM_ELEMS || num_term == _NUM_ELEM_ARG) 
+  return term_char;
+if (num_term <=0) num_term = (int)elem_len;
+for (num=0; ; num++) {
+  for (i=0; i<(unsigned)num_term && *strv==term_char; i++,strv++);
+  if (i==(unsigned)num_term) break;
+  else strv += elem_len-i;
+}
+return (int)num;
+}
+/* #endif removed 2/10/98 (CFITSIO) */
+
+/*-------------------------------------------------------------------------*/
+
+/*           UTILITIES FOR C TO USE STRINGS IN FORTRAN COMMON BLOCKS       */
+
+/* C string TO Fortran Common Block STRing. */
+/* DIM is the number of DIMensions of the array in terms of strings, not
+   characters. e.g. char a[12] has DIM = 0, char a[12][4] has DIM = 1, etc. */
+#define C2FCBSTR(CSTR,FSTR,DIM)                                                \
+ c2fstrv((char *)CSTR, (char *)FSTR, sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,    \
+         sizeof(FSTR)+cfelementsof(FSTR,DIM))
+
+/* Fortran Common Block string TO C STRing. */
+#define FCB2CSTR(FSTR,CSTR,DIM)                                                \
+ vkill_trailing(f2cstrv((char *)FSTR, (char *)CSTR,                            \
+                        sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,                 \
+                        sizeof(FSTR)+cfelementsof(FSTR,DIM)),                  \
+                sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,                         \
+                sizeof(FSTR)+cfelementsof(FSTR,DIM), ' ')
+
+#define cfDEREFERENCE0
+#define cfDEREFERENCE1 *
+#define cfDEREFERENCE2 **
+#define cfDEREFERENCE3 ***
+#define cfDEREFERENCE4 ****
+#define cfDEREFERENCE5 *****
+#define cfelementsof(A,D) (sizeof(A)/sizeof(_(cfDEREFERENCE,D)(A)))
+
+/*-------------------------------------------------------------------------*/
+
+/*               UTILITIES FOR C TO CALL FORTRAN SUBROUTINES               */
+
+/* Define lookup tables for how to handle the various types of variables.  */
+
+#ifdef OLD_VAXC                                /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#define ZTRINGV_NUM(I)       I
+#define ZTRINGV_ARGFP(I) (*(_2(A,I))) /* Undocumented. For PINT, etc. */
+#define ZTRINGV_ARGF(I) _2(A,I)
+#ifdef CFSUBASFUN
+#define ZTRINGV_ARGS(I) ZTRINGV_ARGF(I)
+#else
+#define ZTRINGV_ARGS(I) _2(B,I)
+#endif
+
+#define    PBYTE_cfVP(A,B) PINT_cfVP(A,B)
+#define  PDOUBLE_cfVP(A,B)
+#define   PFLOAT_cfVP(A,B)
+#ifdef ZTRINGV_ARGS_allows_Pvariables
+/* This allows Pvariables for ARGS. ARGF machinery is above ARGFP.
+ * B is not needed because the variable may be changed by the Fortran routine,
+ * but because B is the only way to access an arbitrary macro argument.       */
+#define     PINT_cfVP(A,B) int  B = (int)A;              /* For ZSTRINGV_ARGS */
+#else
+#define     PINT_cfVP(A,B)
+#endif
+#define PLOGICAL_cfVP(A,B) int *B;      /* Returning LOGICAL in FUNn and SUBn */
+#define    PLONG_cfVP(A,B) PINT_cfVP(A,B)
+#define   PSHORT_cfVP(A,B) PINT_cfVP(A,B)
+
+#define        VCF_INT_S(T,A,B) _(T,VVVVVVV_cfTYPE) B = A;
+#define        VCF_INT_F(T,A,B) _(T,_cfVCF)(A,B)
+/* _cfVCF table is directly mapped to _cfCCC table. */
+#define     BYTE_cfVCF(A,B)
+#define   DOUBLE_cfVCF(A,B)
+#if !defined(__CF__KnR)
+#define    FLOAT_cfVCF(A,B)
+#else
+#define    FLOAT_cfVCF(A,B) FORTRAN_REAL B = A;
+#endif
+#define      INT_cfVCF(A,B)
+#define  LOGICAL_cfVCF(A,B)
+#define     LONG_cfVCF(A,B)
+#define    SHORT_cfVCF(A,B)
+
+/* 980416
+   Cast (void (*)(CF_NULL_PROTO)) causes SunOS CC 4.2 occasionally to barf,
+   while the following equivalent typedef is fine.
+   For consistency use the typedef on all machines.
+ */
+typedef void (*cfCAST_FUNCTION)(CF_NULL_PROTO);
+
+#define VCF(TN,I)       _Icf4(4,V,TN,_(A,I),_(B,I),F)
+#define VVCF(TN,AI,BI)  _Icf4(4,V,TN,AI,BI,S)
+#define        INT_cfV(T,A,B,F) _(VCF_INT_,F)(T,A,B)
+#define       INTV_cfV(T,A,B,F)
+#define      INTVV_cfV(T,A,B,F)
+#define     INTVVV_cfV(T,A,B,F)
+#define    INTVVVV_cfV(T,A,B,F)
+#define   INTVVVVV_cfV(T,A,B,F)
+#define  INTVVVVVV_cfV(T,A,B,F)
+#define INTVVVVVVV_cfV(T,A,B,F)
+#define PINT_cfV(      T,A,B,F) _(T,_cfVP)(A,B)
+#define PVOID_cfV(     T,A,B,F)
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define    ROUTINE_cfV(T,A,B,F) void (*B)(CF_NULL_PROTO) = (cfCAST_FUNCTION)A;
+#else
+#define    ROUTINE_cfV(T,A,B,F)
+#endif
+#define     SIMPLE_cfV(T,A,B,F)
+#ifdef vmsFortran
+#define     STRING_cfV(T,A,B,F) static struct {fstring f; unsigned clen;} B =  \
+                                       {{0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL},0};
+#define    PSTRING_cfV(T,A,B,F) static fstring B={0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};
+#define    STRINGV_cfV(T,A,B,F) static fstringvector B =                       \
+  {sizeof(A),DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
+#define   PSTRINGV_cfV(T,A,B,F) static fstringvector B =                       \
+          {0,DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
+#else
+#define     STRING_cfV(T,A,B,F) struct {unsigned int clen, flen; char *nombre;} B;
+#define    STRINGV_cfV(T,A,B,F) struct {char *s, *fs; unsigned flen; char *nombre;} B;
+#define    PSTRING_cfV(T,A,B,F) int     B;
+#define   PSTRINGV_cfV(T,A,B,F) struct{char *fs; unsigned int sizeofA,flen;}B;
+#endif
+#define    ZTRINGV_cfV(T,A,B,F)  STRINGV_cfV(T,A,B,F)
+#define   PZTRINGV_cfV(T,A,B,F) PSTRINGV_cfV(T,A,B,F)
+
+/* Note that the actions of the A table were performed inside the AA table.
+   VAX Ultrix vcc, and HP-UX cc, didn't evaluate arguments to functions left to
+   right, so we had to split the original table into the current robust two. */
+#define ACF(NAME,TN,AI,I)      _(TN,_cfSTR)(4,A,NAME,I,AI,_(B,I),0)
+#define   DEFAULT_cfA(M,I,A,B)
+#define   LOGICAL_cfA(M,I,A,B) B=C2FLOGICAL(B);
+#define  PLOGICAL_cfA(M,I,A,B) A=C2FLOGICAL(A);
+#define    STRING_cfA(M,I,A,B)  STRING_cfC(M,I,A,B,sizeof(A))
+#define   PSTRING_cfA(M,I,A,B) PSTRING_cfC(M,I,A,B,sizeof(A))
+#ifdef vmsFortran
+#define  AATRINGV_cfA(    A,B, sA,filA,silA)                                   \
+ initfstr(B,_cf_malloc((sA)-(filA)),(filA),(silA)-1),                          \
+          c2fstrv(A,B.dsc$a_pointer,(silA),(sA));
+#define APATRINGV_cfA(    A,B, sA,filA,silA)                                   \
+ initfstr(B,A,(filA),(silA)-1),c2fstrv(A,A,(silA),(sA));
+#else
+#define  AATRINGV_cfA(    A,B, sA,filA,silA)                                   \
+     (B.s=_cf_malloc((sA)-(filA)),B.fs=c2fstrv(A,B.s,(B.flen=(silA)-1)+1,(sA)));
+#define APATRINGV_cfA(    A,B, sA,filA,silA)                                   \
+ B.fs=c2fstrv(A,A,(B.flen=(silA)-1)+1,B.sizeofA=(sA));
+#endif
+#define   STRINGV_cfA(M,I,A,B)                                                 \
+    AATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
+#define  PSTRINGV_cfA(M,I,A,B)                                                 \
+   APATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
+#define   ZTRINGV_cfA(M,I,A,B)  AATRINGV_cfA( (char *)A,B,                     \
+                    (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1),                \
+                              (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)
+#define  PZTRINGV_cfA(M,I,A,B) APATRINGV_cfA( (char *)A,B,                     \
+                    (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1),                \
+                              (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)
+
+#define    PBYTE_cfAAP(A,B) &A
+#define  PDOUBLE_cfAAP(A,B) &A
+#define   PFLOAT_cfAAP(A,B) FLOATVVVVVVV_cfPP &A
+#define     PINT_cfAAP(A,B) &A
+#define PLOGICAL_cfAAP(A,B) B= &A         /* B used to keep a common W table. */
+#define    PLONG_cfAAP(A,B) &A
+#define   PSHORT_cfAAP(A,B) &A
+
+#define AACF(TN,AI,I,C) _SEP_(TN,C,cfCOMMA) _Icf(3,AA,TN,AI,_(B,I))
+#define        INT_cfAA(T,A,B) &B
+#define       INTV_cfAA(T,A,B) _(T,VVVVVV_cfPP) A
+#define      INTVV_cfAA(T,A,B) _(T,VVVVV_cfPP)  A[0]
+#define     INTVVV_cfAA(T,A,B) _(T,VVVV_cfPP)   A[0][0]
+#define    INTVVVV_cfAA(T,A,B) _(T,VVV_cfPP)    A[0][0][0]
+#define   INTVVVVV_cfAA(T,A,B) _(T,VV_cfPP)     A[0][0][0][0]
+#define  INTVVVVVV_cfAA(T,A,B) _(T,V_cfPP)      A[0][0][0][0][0]
+#define INTVVVVVVV_cfAA(T,A,B) _(T,_cfPP)       A[0][0][0][0][0][0]
+#define       PINT_cfAA(T,A,B) _(T,_cfAAP)(A,B)
+#define      PVOID_cfAA(T,A,B) (void *) A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define    ROUTINE_cfAA(T,A,B) &B
+#else
+#define    ROUTINE_cfAA(T,A,B) (cfCAST_FUNCTION)A
+#endif
+#define     STRING_cfAA(T,A,B)  STRING_cfCC(T,A,B)
+#define    PSTRING_cfAA(T,A,B) PSTRING_cfCC(T,A,B)
+#ifdef vmsFortran
+#define    STRINGV_cfAA(T,A,B) &B
+#else
+#ifdef CRAYFortran
+#define    STRINGV_cfAA(T,A,B) _cptofcd(B.fs,B.flen)
+#else
+#define    STRINGV_cfAA(T,A,B) B.fs
+#endif
+#endif
+#define   PSTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+#define    ZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+#define   PZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define JCF(TN,I)
+#define KCF(TN,I)
+#else
+#define JCF(TN,I)    _(TN,_cfSTR)(1,J,_(B,I), 0,0,0,0)
+#if defined(AbsoftUNIXFortran)
+#define  DEFAULT_cfJ(B) ,0
+#else
+#define  DEFAULT_cfJ(B)
+#endif
+#define  LOGICAL_cfJ(B) DEFAULT_cfJ(B)
+#define PLOGICAL_cfJ(B) DEFAULT_cfJ(B)
+#define   STRING_cfJ(B) ,B.flen
+#define  PSTRING_cfJ(B) ,B
+#define  STRINGV_cfJ(B) STRING_cfJ(B)
+#define PSTRINGV_cfJ(B) STRING_cfJ(B)
+#define  ZTRINGV_cfJ(B) STRING_cfJ(B)
+#define PZTRINGV_cfJ(B) STRING_cfJ(B)
+
+/* KCF is identical to DCF, except that KCF ZTRING is not empty. */
+#define KCF(TN,I)    _(TN,_cfSTR)(1,KK,_(B,I), 0,0,0,0)
+#if defined(AbsoftUNIXFortran)
+#define  DEFAULT_cfKK(B) , unsigned B
+#else
+#define  DEFAULT_cfKK(B)
+#endif
+#define  LOGICAL_cfKK(B) DEFAULT_cfKK(B)
+#define PLOGICAL_cfKK(B) DEFAULT_cfKK(B)
+#define   STRING_cfKK(B) , unsigned B
+#define  PSTRING_cfKK(B) STRING_cfKK(B)
+#define  STRINGV_cfKK(B) STRING_cfKK(B)
+#define PSTRINGV_cfKK(B) STRING_cfKK(B)
+#define  ZTRINGV_cfKK(B) STRING_cfKK(B)
+#define PZTRINGV_cfKK(B) STRING_cfKK(B)
+#endif
+
+#define WCF(TN,AN,I)      _(TN,_cfSTR)(2,W,AN,_(B,I), 0,0,0)
+#define  DEFAULT_cfW(A,B)
+#define  LOGICAL_cfW(A,B)
+#define PLOGICAL_cfW(A,B) *B=F2CLOGICAL(*B);
+#define   STRING_cfW(A,B) (B.nombre=A,B.nombre[B.clen]!='\0'?B.nombre[B.clen]='\0':0); /* A?="constnt"*/
+#define  PSTRING_cfW(A,B) kill_trailing(A,' ');
+#ifdef vmsFortran
+#define  STRINGV_cfW(A,B) _cf_free(B.dsc$a_pointer);
+#define PSTRINGV_cfW(A,B)                                                      \
+  vkill_trailing(f2cstrv((char*)A, (char*)A,                                   \
+                           B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0]),     \
+                   B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0], ' ');
+#else
+#define  STRINGV_cfW(A,B) _cf_free(B.s);
+#define PSTRINGV_cfW(A,B) vkill_trailing(                                      \
+         f2cstrv((char*)A,(char*)A,B.flen+1,B.sizeofA), B.flen+1,B.sizeofA,' ');
+#endif
+#define  ZTRINGV_cfW(A,B)      STRINGV_cfW(A,B)
+#define PZTRINGV_cfW(A,B)     PSTRINGV_cfW(A,B)
+
+#define   NCF(TN,I,C)       _SEP_(TN,C,cfCOMMA) _Icf(2,N,TN,_(A,I),0) 
+#define  NNCF(TN,I,C)        UUCF(TN,I,C)
+#define NNNCF(TN,I,C)       _SEP_(TN,C,cfCOLON) _Icf(2,N,TN,_(A,I),0) 
+#define        INT_cfN(T,A) _(T,VVVVVVV_cfTYPE) * A
+#define       INTV_cfN(T,A) _(T,VVVVVV_cfTYPE)  * A
+#define      INTVV_cfN(T,A) _(T,VVVVV_cfTYPE)   * A
+#define     INTVVV_cfN(T,A) _(T,VVVV_cfTYPE)    * A
+#define    INTVVVV_cfN(T,A) _(T,VVV_cfTYPE)     * A
+#define   INTVVVVV_cfN(T,A) _(T,VV_cfTYPE)      * A
+#define  INTVVVVVV_cfN(T,A) _(T,V_cfTYPE)       * A
+#define INTVVVVVVV_cfN(T,A) _(T,_cfTYPE)        * A
+#define       PINT_cfN(T,A) _(T,_cfTYPE)        * A
+#define      PVOID_cfN(T,A) void *                A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define    ROUTINE_cfN(T,A) void (**A)(CF_NULL_PROTO)
+#else
+#define    ROUTINE_cfN(T,A) void ( *A)(CF_NULL_PROTO)
+#endif
+#ifdef vmsFortran
+#define     STRING_cfN(T,A) fstring *             A
+#define    STRINGV_cfN(T,A) fstringvector *       A
+#else
+#ifdef CRAYFortran
+#define     STRING_cfN(T,A) _fcd                  A
+#define    STRINGV_cfN(T,A) _fcd                  A
+#else
+#define     STRING_cfN(T,A) char *                A
+#define    STRINGV_cfN(T,A) char *                A
+#endif
+#endif
+#define    PSTRING_cfN(T,A)   STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define   PNSTRING_cfN(T,A)   STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define   PPSTRING_cfN(T,A)   STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define   PSTRINGV_cfN(T,A)  STRINGV_cfN(T,A)
+#define    ZTRINGV_cfN(T,A)  STRINGV_cfN(T,A)
+#define   PZTRINGV_cfN(T,A) PSTRINGV_cfN(T,A)
+
+
+/* Apollo 6.7, CRAY, old Sun, VAX/Ultrix vcc/cc and new ultrix
+   can't hack more than 31 arg's.
+   e.g. ultrix >= 4.3 gives message:
+       zow35> cc -c -DDECFortran cfortest.c
+       cfe: Fatal: Out of memory: cfortest.c
+       zow35>
+   Old __hpux had the problem, but new 'HP-UX A.09.03 A 9000/735' is fine
+   if using -Aa, otherwise we have a problem.
+ */
+#ifndef MAX_PREPRO_ARGS
+#if !defined(__GNUC__) && (defined(VAXUltrix) || defined(__CF__APOLLO67) || (defined(sun)&&!defined(__sun)) || defined(_CRAY) || defined(__ultrix__) || (defined(__hpux)&&defined(__CF__KnR)))
+#define MAX_PREPRO_ARGS 31
+#else
+#define MAX_PREPRO_ARGS 99
+#endif
+#endif
+
+#if defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+/* In addition to explicit Absoft stuff, only Absoft requires:
+   - DEFAULT coming from _cfSTR.
+     DEFAULT could have been called e.g. INT, but keep it for clarity.
+   - M term in CFARGT14 and CFARGT14FS.
+ */
+#define ABSOFT_cf1(T0) _(T0,_cfSTR)(0,ABSOFT1,0,0,0,0,0)
+#define ABSOFT_cf2(T0) _(T0,_cfSTR)(0,ABSOFT2,0,0,0,0,0)
+#define ABSOFT_cf3(T0) _(T0,_cfSTR)(0,ABSOFT3,0,0,0,0,0)
+#define DEFAULT_cfABSOFT1
+#define LOGICAL_cfABSOFT1
+#define  STRING_cfABSOFT1 ,MAX_LEN_FORTRAN_FUNCTION_STRING
+#define DEFAULT_cfABSOFT2
+#define LOGICAL_cfABSOFT2
+#define  STRING_cfABSOFT2 ,unsigned D0
+#define DEFAULT_cfABSOFT3
+#define LOGICAL_cfABSOFT3
+#define  STRING_cfABSOFT3 ,D0
+#else
+#define ABSOFT_cf1(T0)
+#define ABSOFT_cf2(T0)
+#define ABSOFT_cf3(T0)
+#endif
+
+/* _Z introduced to cicumvent IBM and HP silly preprocessor warning.
+   e.g. "Macro CFARGT14 invoked with a null argument."
+ */
+#define _Z
+
+#define  CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)                \
+ S(T1,1)   S(T2,2)   S(T3,3)    S(T4,4)    S(T5,5)    S(T6,6)    S(T7,7)       \
+ S(T8,8)   S(T9,9)   S(TA,10)   S(TB,11)   S(TC,12)   S(TD,13)   S(TE,14)
+#define  CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ S(T1,1)   S(T2,2)   S(T3,3)    S(T4,4)    S(T5,5)    S(T6,6)    S(T7,7)       \
+ S(T8,8)   S(T9,9)   S(TA,10)   S(TB,11)   S(TC,12)   S(TD,13)   S(TE,14)      \
+ S(TF,15)  S(TG,16)  S(TH,17)   S(TI,18)   S(TJ,19)   S(TK,20)   S(TL,21)      \
+ S(TM,22)  S(TN,23)  S(TO,24)   S(TP,25)   S(TQ,26)   S(TR,27)
+
+#define  CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)           \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1)  F(T4,4,1)  F(T5,5,1)  F(T6,6,1)  F(T7,7,1)     \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1)    \
+ M       CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define  CFARGT27FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0)  F(T2,2,1)  F(T3,3,1)  F(T4,4,1)  F(T5,5,1)  F(T6,6,1)  F(T7,7,1)   \
+ F(T8,8,1)  F(T9,9,1)  F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1)  \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1)  \
+ F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1)             \
+ M       CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+#if !(defined(PowerStationFortran)||defined(hpuxFortran800))
+/*  Old CFARGT14 -> CFARGT14FS as seen below, for Absoft cross-compile yields:
+      SunOS> cc -c -Xa -DAbsoftUNIXFortran c.c
+      "c.c", line 406: warning: argument mismatch
+    Haven't checked if this is ANSI C or a SunOS bug. SunOS -Xs works ok.
+    Behavior is most clearly seen in example:
+      #define A 1 , 2
+      #define  C(X,Y,Z) x=X. y=Y. z=Z.
+      #define  D(X,Y,Z) C(X,Y,Z)
+      D(x,A,z)
+    Output from preprocessor is: x = x . y = 1 . z = 2 .
+ #define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+       CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+*/
+#define  CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)             \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1)  F(T4,4,1)  F(T5,5,1)  F(T6,6,1)  F(T7,7,1)     \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1)    \
+ M       CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define  CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0)  F(T2,2,1)  F(T3,3,1)  F(T4,4,1)  F(T5,5,1)  F(T6,6,1)  F(T7,7,1)   \
+ F(T8,8,1)  F(T9,9,1)  F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1)  \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1)  \
+ F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1)             \
+ M       CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+#define  CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ F(T1,1,0)  F(T2,2,1)  F(T3,3,1)  F(T4,4,1)  F(T5,5,1)  F(T6,6,1)  F(T7,7,1)   \
+ F(T8,8,1)  F(T9,9,1)  F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1)  \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1)             \
+ S(T1,1)    S(T2,2)    S(T3,3)    S(T4,4)    S(T5,5)    S(T6,6)    S(T7,7)     \
+ S(T8,8)    S(T9,9)    S(TA,10)   S(TB,11)   S(TC,12)   S(TD,13)   S(TE,14)    \
+ S(TF,15)   S(TG,16)   S(TH,17)   S(TI,18)   S(TJ,19)   S(TK,20)
+#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \
+ F(T1,A1,1,0)  F(T2,A2,2,1)  F(T3,A3,3,1) F(T4,A4,4,1)  F(T5,A5,5,1)  F(T6,A6,6,1)  \
+ F(T7,A7,7,1)  F(T8,A8,8,1)  F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
+ F(TD,AD,13,1) F(TE,AE,14,1) S(T1,1)      S(T2,2)       S(T3,3)       S(T4,4)       \
+ S(T5,5)       S(T6,6)       S(T7,7)      S(T8,8)       S(T9,9)       S(TA,10)      \
+ S(TB,11)      S(TC,12)      S(TD,13)     S(TE,14)
+#if MAX_PREPRO_ARGS>31
+#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+ F(T1,A1,1,0)  F(T2,A2,2,1)  F(T3,A3,3,1)  F(T4,A4,4,1)  F(T5,A5,5,1)  F(T6,A6,6,1)  \
+ F(T7,A7,7,1)  F(T8,A8,8,1)  F(T9,A9,9,1)  F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
+ F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \
+ F(TJ,AJ,19,1) F(TK,AK,20,1) S(T1,1)       S(T2,2)       S(T3,3)       S(T4,4)       \
+ S(T5,5)       S(T6,6)       S(T7,7)       S(T8,8)       S(T9,9)       S(TA,10)      \
+ S(TB,11)      S(TC,12)      S(TD,13)      S(TE,14)      S(TF,15)      S(TG,16)      \
+ S(TH,17)      S(TI,18)      S(TJ,19)      S(TK,20)
+#define CFARGTA27(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+ F(T1,A1,1,0)  F(T2,A2,2,1)  F(T3,A3,3,1)  F(T4,A4,4,1)  F(T5,A5,5,1)  F(T6,A6,6,1)  \
+ F(T7,A7,7,1)  F(T8,A8,8,1)  F(T9,A9,9,1)  F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
+ F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \
+ F(TJ,AJ,19,1) F(TK,AK,20,1) F(TL,AL,21,1) F(TM,AM,22,1) F(TN,AN,23,1) F(TO,AO,24,1) \
+ F(TP,AP,25,1) F(TQ,AQ,26,1) F(TR,AR,27,1) S(T1,1)       S(T2,2)       S(T3,3)       \
+ S(T4,4)       S(T5,5)       S(T6,6)       S(T7,7)       S(T8,8)       S(T9,9)       \
+ S(TA,10)      S(TB,11)      S(TC,12)      S(TD,13)      S(TE,14)      S(TF,15)      \
+ S(TG,16)      S(TH,17)      S(TI,18)      S(TJ,19)      S(TK,20)      S(TL,21)      \
+ S(TM,22)      S(TN,23)      S(TO,24)      S(TP,25)      S(TQ,26)      S(TR,27)
+#endif
+#else
+#define  CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)             \
+ F(T1,1,0) S(T1,1) F(T2,2,1)  S(T2,2)  F(T3,3,1)  S(T3,3)  F(T4,4,1)  S(T4,4)  \
+ F(T5,5,1) S(T5,5) F(T6,6,1)  S(T6,6)  F(T7,7,1)  S(T7,7)  F(T8,8,1)  S(T8,8)  \
+ F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14)
+#define  CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0)  S(T1,1)  F(T2,2,1)  S(T2,2)  F(T3,3,1)  S(T3,3)  F(T4,4,1)  S(T4,4)  \
+ F(T5,5,1)  S(T5,5)  F(T6,6,1)  S(T6,6)  F(T7,7,1)  S(T7,7)  F(T8,8,1)  S(T8,8)  \
+ F(T9,9,1)  S(T9,9)  F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \
+ F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20) \
+ F(TL,21,1) S(TL,21) F(TM,22,1) S(TM,22) F(TN,23,1) S(TN,23) F(TO,24,1) S(TO,24) \
+ F(TP,25,1) S(TP,25) F(TQ,26,1) S(TQ,26) F(TR,27,1) S(TR,27)
+
+#define  CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ F(T1,1,0)  S(T1,1)  F(T2,2,1)  S(T2,2)  F(T3,3,1)  S(T3,3)  F(T4,4,1)  S(T4,4)  \
+ F(T5,5,1)  S(T5,5)  F(T6,6,1)  S(T6,6)  F(T7,7,1)  S(T7,7)  F(T8,8,1)  S(T8,8)  \
+ F(T9,9,1)  S(T9,9)  F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \
+ F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20)
+#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \
+ F(T1,A1,1,0)  S(T1,1)  F(T2,A2,2,1)  S(T2,2)  F(T3,A3,3,1)  S(T3,3)           \
+ F(T4,A4,4,1)  S(T4,4)  F(T5,A5,5,1)  S(T5,5)  F(T6,A6,6,1)  S(T6,6)           \
+ F(T7,A7,7,1)  S(T7,7)  F(T8,A8,8,1)  S(T8,8)  F(T9,A9,9,1)  S(T9,9)           \
+ F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12)          \
+ F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14)
+#if MAX_PREPRO_ARGS>31
+#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+ F(T1,A1,1,0)  S(T1,1)  F(T2,A2,2,1)  S(T2,2)  F(T3,A3,3,1)  S(T3,3)           \
+ F(T4,A4,4,1)  S(T4,4)  F(T5,A5,5,1)  S(T5,5)  F(T6,A6,6,1)  S(T6,6)           \
+ F(T7,A7,7,1)  S(T7,7)  F(T8,A8,8,1)  S(T8,8)  F(T9,A9,9,1)  S(T9,9)           \
+ F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12)          \
+ F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) F(TF,AF,15,1) S(TF,15)          \
+ F(TG,AG,16,1) S(TG,16) F(TH,AH,17,1) S(TH,17) F(TI,AI,18,1) S(TI,18)          \
+ F(TJ,AJ,19,1) S(TJ,19) F(TK,AK,20,1) S(TK,20)                
+#define CFARGTA27(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+ F(T1,A1,1,0)  S(T1,1)  F(T2,A2,2,1)  S(T2,2)  F(T3,A3,3,1)  S(T3,3)           \
+ F(T4,A4,4,1)  S(T4,4)  F(T5,A5,5,1)  S(T5,5)  F(T6,A6,6,1)  S(T6,6)           \
+ F(T7,A7,7,1)  S(T7,7)  F(T8,A8,8,1)  S(T8,8)  F(T9,A9,9,1)  S(T9,9)           \
+ F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12)          \
+ F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) F(TF,AF,15,1) S(TF,15)          \
+ F(TG,AG,16,1) S(TG,16) F(TH,AH,17,1) S(TH,17) F(TI,AI,18,1) S(TI,18)          \
+ F(TJ,AJ,19,1) S(TJ,19) F(TK,AK,20,1) S(TK,20) F(TL,AL,21,1) S(TL,21)          \
+ F(TM,AM,22,1) S(TM,22) F(TN,AN,23,1) S(TN,23) F(TO,AO,24,1) S(TO,24)          \
+ F(TP,AP,25,1) S(TP,25) F(TQ,AQ,26,1) S(TQ,26) F(TR,AR,27,1) S(TR,27)
+#endif
+#endif
+
+
+#define PROTOCCALLSFSUB1( UN,LN,T1) \
+        PROTOCCALLSFSUB14(UN,LN,T1,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB2( UN,LN,T1,T2) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB3( UN,LN,T1,T2,T3) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB4( UN,LN,T1,T2,T3,T4) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define PROTOCCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+
+#define PROTOCCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0)
+#define PROTOCCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0)
+
+#define PROTOCCALLSFSUB21(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \
+        PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB22(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \
+        PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB23(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \
+        PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB24(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \
+        PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB25(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \
+        PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0)
+#define PROTOCCALLSFSUB26(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \
+        PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0)
+
+
+#ifndef FCALLSC_QUALIFIER
+#ifdef VISUAL_CPLUSPLUS
+#define FCALLSC_QUALIFIER __stdcall
+#else
+#define FCALLSC_QUALIFIER
+#endif
+#endif
+
+#ifdef __cplusplus
+#define CFextern extern "C"
+#else
+#define CFextern extern
+#endif
+
+
+#ifdef CFSUBASFUN
+#define PROTOCCALLSFSUB0(UN,LN) \
+   PROTOCCALLSFFUN0( VOID,UN,LN)
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+   PROTOCCALLSFFUN14(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\
+   PROTOCCALLSFFUN20(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)\
+   PROTOCCALLSFFUN27(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+#else
+/* Note: Prevent compiler warnings, null #define PROTOCCALLSFSUB14/20 after 
+   #include-ing cfortran.h if calling the FORTRAN wrapper within the same 
+   source code where the wrapper is created. */
+#define PROTOCCALLSFSUB0(UN,LN)     _(VOID,_cfPU)(CFC_(UN,LN))();
+#ifndef __CF__KnR
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT14(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) );
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\
+ _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT20(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) );
+#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)\
+ _(VOID,_cfPU)(CFC_(UN,LN))( CFARGT27(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) );
+#else
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)     \
+         PROTOCCALLSFSUB0(UN,LN)
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+         PROTOCCALLSFSUB0(UN,LN)
+#define PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+         PROTOCCALLSFSUB0(UN,LN)
+#endif
+#endif
+
+
+#ifdef OLD_VAXC                                  /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+
+#define CCALLSFSUB1( UN,LN,T1,                        A1)         \
+        CCALLSFSUB5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0)
+#define CCALLSFSUB2( UN,LN,T1,T2,                     A1,A2)      \
+        CCALLSFSUB5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0)
+#define CCALLSFSUB3( UN,LN,T1,T2,T3,                  A1,A2,A3)   \
+        CCALLSFSUB5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0)
+#define CCALLSFSUB4( UN,LN,T1,T2,T3,T4,               A1,A2,A3,A4)\
+        CCALLSFSUB5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0)
+#define CCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5,            A1,A2,A3,A4,A5)          \
+        CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0)
+#define CCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6,         A1,A2,A3,A4,A5,A6)       \
+        CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0)
+#define CCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7,      A1,A2,A3,A4,A5,A6,A7)    \
+        CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0)
+#define CCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,   A1,A2,A3,A4,A5,A6,A7,A8) \
+        CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0)
+#define CCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\
+        CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0)
+#define CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\
+        CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0)
+#define CCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\
+        CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0)
+#define CCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\
+        CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0)
+#define CCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\
+        CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0)
+
+#ifdef __cplusplus
+#define CPPPROTOCLSFSUB0( UN,LN)
+#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+#else
+#define CPPPROTOCLSFSUB0(UN,LN) \
+        PROTOCCALLSFSUB0(UN,LN)
+#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)     \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+        PROTOCCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+#endif
+
+#ifdef CFSUBASFUN
+#define CCALLSFSUB0(UN,LN) CCALLSFFUN0(UN,LN)
+#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+        CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)
+#else
+/* do{...}while(0) allows if(a==b) FORT(); else BORT(); */
+#define CCALLSFSUB0( UN,LN) do{CPPPROTOCLSFSUB0(UN,LN) CFC_(UN,LN)();}while(0)
+#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5)  \
+   VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \
+   VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14)             \
+   CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)          \
+   ACF(LN,T1,A1,1)  ACF(LN,T2,A2,2)  ACF(LN,T3,A3,3)                           \
+   ACF(LN,T4,A4,4)  ACF(LN,T5,A5,5)  ACF(LN,T6,A6,6)  ACF(LN,T7,A7,7)          \
+   ACF(LN,T8,A8,8)  ACF(LN,T9,A9,9)  ACF(LN,TA,AA,10) ACF(LN,TB,AB,11)         \
+   ACF(LN,TC,AC,12) ACF(LN,TD,AD,13) ACF(LN,TE,AE,14)                          \
+   CFC_(UN,LN)( CFARGTA14(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) );\
+   WCF(T1,A1,1)  WCF(T2,A2,2)  WCF(T3,A3,3)  WCF(T4,A4,4)  WCF(T5,A5,5)        \
+   WCF(T6,A6,6)  WCF(T7,A7,7)  WCF(T8,A8,8)  WCF(T9,A9,9)  WCF(TA,AA,10)       \
+   WCF(TB,AB,11) WCF(TC,AC,12) WCF(TD,AD,13) WCF(TE,AE,14)      }while(0)
+#endif
+
+
+#if MAX_PREPRO_ARGS>31
+#define CCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF)\
+        CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,0,0,0,0,0)
+#define CCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG)\
+        CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,0,0,0,0)
+#define CCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH)\
+        CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,0,0,0)
+#define CCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI)\
+        CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,0,0)
+#define CCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ)\
+        CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,0)
+
+#ifdef CFSUBASFUN
+#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+        TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+        CCALLSFFUN20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+        TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK)
+#else
+#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+        TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+do{VVCF(T1,A1,B1)  VVCF(T2,A2,B2)  VVCF(T3,A3,B3)  VVCF(T4,A4,B4)  VVCF(T5,A5,B5)   \
+   VVCF(T6,A6,B6)  VVCF(T7,A7,B7)  VVCF(T8,A8,B8)  VVCF(T9,A9,B9)  VVCF(TA,AA,B10)  \
+   VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) VVCF(TF,AF,B15)  \
+   VVCF(TG,AG,B16) VVCF(TH,AH,B17) VVCF(TI,AI,B18) VVCF(TJ,AJ,B19) VVCF(TK,AK,B20)  \
+   CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)  \
+   ACF(LN,T1,A1,1)  ACF(LN,T2,A2,2)  ACF(LN,T3,A3,3)  ACF(LN,T4,A4,4)          \
+   ACF(LN,T5,A5,5)  ACF(LN,T6,A6,6)  ACF(LN,T7,A7,7)  ACF(LN,T8,A8,8)          \
+   ACF(LN,T9,A9,9)  ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) ACF(LN,TC,AC,12)         \
+   ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) ACF(LN,TF,AF,15) ACF(LN,TG,AG,16)         \
+   ACF(LN,TH,AH,17) ACF(LN,TI,AI,18) ACF(LN,TJ,AJ,19) ACF(LN,TK,AK,20)         \
+   CFC_(UN,LN)( CFARGTA20(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) ); \
+ WCF(T1,A1,1)  WCF(T2,A2,2)  WCF(T3,A3,3)  WCF(T4,A4,4)  WCF(T5,A5,5)  WCF(T6,A6,6)  \
+ WCF(T7,A7,7)  WCF(T8,A8,8)  WCF(T9,A9,9)  WCF(TA,AA,10) WCF(TB,AB,11) WCF(TC,AC,12) \
+ WCF(TD,AD,13) WCF(TE,AE,14) WCF(TF,AF,15) WCF(TG,AG,16) WCF(TH,AH,17) WCF(TI,AI,18) \
+ WCF(TJ,AJ,19) WCF(TK,AK,20) }while(0)
+#endif
+#endif         /* MAX_PREPRO_ARGS */
+
+#if MAX_PREPRO_ARGS>31
+#define CCALLSFSUB21(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL)\
+        CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,0,0,0,0,0,0)
+#define CCALLSFSUB22(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM)\
+        CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,0,0,0,0,0)
+#define CCALLSFSUB23(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN)\
+        CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,0,0,0,0)
+#define CCALLSFSUB24(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO)\
+        CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,0,0,0)
+#define CCALLSFSUB25(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP)\
+        CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,0,0)
+#define CCALLSFSUB26(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ)\
+        CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,0)
+
+#ifdef CFSUBASFUN
+#define CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \
+                           A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+        CCALLSFFUN27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \
+                           A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR)
+#else
+#define CCALLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR, \
+                           A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
+do{VVCF(T1,A1,B1)  VVCF(T2,A2,B2)  VVCF(T3,A3,B3)  VVCF(T4,A4,B4)  VVCF(T5,A5,B5)   \
+   VVCF(T6,A6,B6)  VVCF(T7,A7,B7)  VVCF(T8,A8,B8)  VVCF(T9,A9,B9)  VVCF(TA,AA,B10)  \
+   VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) VVCF(TF,AF,B15)  \
+   VVCF(TG,AG,B16) VVCF(TH,AH,B17) VVCF(TI,AI,B18) VVCF(TJ,AJ,B19) VVCF(TK,AK,B20)  \
+   VVCF(TL,AL,B21) VVCF(TM,AM,B22) VVCF(TN,AN,B23) VVCF(TO,AO,B24) VVCF(TP,AP,B25)  \
+   VVCF(TQ,AQ,B26) VVCF(TR,AR,B27)                                                  \
+   CPPPROTOCLSFSUB27(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+   ACF(LN,T1,A1,1)  ACF(LN,T2,A2,2)  ACF(LN,T3,A3,3)  ACF(LN,T4,A4,4)          \
+   ACF(LN,T5,A5,5)  ACF(LN,T6,A6,6)  ACF(LN,T7,A7,7)  ACF(LN,T8,A8,8)          \
+   ACF(LN,T9,A9,9)  ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) ACF(LN,TC,AC,12)         \
+   ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) ACF(LN,TF,AF,15) ACF(LN,TG,AG,16)         \
+   ACF(LN,TH,AH,17) ACF(LN,TI,AI,18) ACF(LN,TJ,AJ,19) ACF(LN,TK,AK,20)         \
+   ACF(LN,TL,AL,21) ACF(LN,TM,AM,22) ACF(LN,TN,AN,23) ACF(LN,TO,AO,24)         \
+   ACF(LN,TP,AP,25) ACF(LN,TQ,AQ,26) ACF(LN,TR,AR,27)                          \
+   CFC_(UN,LN)( CFARGTA27(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,\
+                                   A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) ); \
+ WCF(T1,A1,1)  WCF(T2,A2,2)  WCF(T3,A3,3)  WCF(T4,A4,4)  WCF(T5,A5,5)  WCF(T6,A6,6)  \
+ WCF(T7,A7,7)  WCF(T8,A8,8)  WCF(T9,A9,9)  WCF(TA,AA,10) WCF(TB,AB,11) WCF(TC,AC,12) \
+ WCF(TD,AD,13) WCF(TE,AE,14) WCF(TF,AF,15) WCF(TG,AG,16) WCF(TH,AH,17) WCF(TI,AI,18) \
+ WCF(TJ,AJ,19) WCF(TK,AK,20) WCF(TL,AL,21) WCF(TM,AM,22) WCF(TN,AN,23) WCF(TO,AO,24) \
+ WCF(TP,AP,25) WCF(TQ,AQ,26) WCF(TR,AR,27) }while(0)
+#endif
+#endif         /* MAX_PREPRO_ARGS */
+
+/*-------------------------------------------------------------------------*/
+
+/*               UTILITIES FOR C TO CALL FORTRAN FUNCTIONS                 */
+
+/*N.B. PROTOCCALLSFFUNn(..) generates code, whether or not the FORTRAN
+  function is called. Therefore, especially for creator's of C header files
+  for large FORTRAN libraries which include many functions, to reduce
+  compile time and object code size, it may be desirable to create
+  preprocessor directives to allow users to create code for only those
+  functions which they use.                                                */
+
+/* The following defines the maximum length string that a function can return.
+   Of course it may be undefine-d and re-define-d before individual
+   PROTOCCALLSFFUNn(..) as required. It would also be nice to have this derived
+   from the individual machines' limits.                                      */
+#define MAX_LEN_FORTRAN_FUNCTION_STRING 0x4FE
+
+/* The following defines a character used by CFORTRAN.H to flag the end of a
+   string coming out of a FORTRAN routine.                                 */
+#define CFORTRAN_NON_CHAR 0x7F
+
+#ifdef OLD_VAXC                                /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#define _SEP_(TN,C,cfCOMMA)     _(__SEP_,C)(TN,cfCOMMA)
+#define __SEP_0(TN,cfCOMMA)  
+#define __SEP_1(TN,cfCOMMA)     _Icf(2,SEP,TN,cfCOMMA,0)
+#define        INT_cfSEP(T,B) _(A,B)
+#define       INTV_cfSEP(T,B) INT_cfSEP(T,B)
+#define      INTVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define     INTVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define    INTVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define   INTVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define  INTVVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define       PINT_cfSEP(T,B) INT_cfSEP(T,B)
+#define      PVOID_cfSEP(T,B) INT_cfSEP(T,B)
+#define    ROUTINE_cfSEP(T,B) INT_cfSEP(T,B)
+#define     SIMPLE_cfSEP(T,B) INT_cfSEP(T,B)
+#define       VOID_cfSEP(T,B) INT_cfSEP(T,B)    /* For FORTRAN calls C subr.s.*/
+#define     STRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define    STRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define    PSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define   PSTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define   PNSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define   PPSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define    ZTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define   PZTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+                         
+#if defined(SIGNED_BYTE) || !defined(UNSIGNED_BYTE)
+#ifdef OLD_VAXC
+#define INTEGER_BYTE               char    /* Old VAXC barfs on 'signed char' */
+#else
+#define INTEGER_BYTE        signed char    /* default */
+#endif
+#else
+#define INTEGER_BYTE        unsigned char
+#endif
+#define    BYTEVVVVVVV_cfTYPE INTEGER_BYTE
+#define  DOUBLEVVVVVVV_cfTYPE DOUBLE_PRECISION 
+#define   FLOATVVVVVVV_cfTYPE FORTRAN_REAL
+#define     INTVVVVVVV_cfTYPE int
+#define LOGICALVVVVVVV_cfTYPE int
+#define    LONGVVVVVVV_cfTYPE long
+#define   SHORTVVVVVVV_cfTYPE short
+#define          PBYTE_cfTYPE INTEGER_BYTE
+#define        PDOUBLE_cfTYPE DOUBLE_PRECISION 
+#define         PFLOAT_cfTYPE FORTRAN_REAL
+#define           PINT_cfTYPE int
+#define       PLOGICAL_cfTYPE int
+#define          PLONG_cfTYPE long
+#define         PSHORT_cfTYPE short
+
+#define CFARGS0(A,T,V,W,X,Y,Z) _3(T,_cf,A)
+#define CFARGS1(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V)
+#define CFARGS2(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W)
+#define CFARGS3(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X)
+#define CFARGS4(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y)
+#define CFARGS5(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y,Z)
+
+#define  _Icf(N,T,I,X,Y)                 _(I,_cfINT)(N,T,I,X,Y,0)
+#define _Icf4(N,T,I,X,Y,Z)               _(I,_cfINT)(N,T,I,X,Y,Z)
+#define           BYTE_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define         DOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INT,B,X,Y,Z,0)
+#define          FLOAT_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define            INT_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define        LOGICAL_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define           LONG_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define          SHORT_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define          PBYTE_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define        PDOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,PINT,B,X,Y,Z,0)
+#define         PFLOAT_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define           PINT_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define       PLOGICAL_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define          PLONG_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define         PSHORT_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define          BYTEV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define         BYTEVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define        BYTEVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define       BYTEVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define      BYTEVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define     BYTEVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define    BYTEVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define        DOUBLEV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTV,B,X,Y,Z,0)
+#define       DOUBLEVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVV,B,X,Y,Z,0)
+#define      DOUBLEVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVV,B,X,Y,Z,0)
+#define     DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVV,B,X,Y,Z,0)
+#define    DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVV,B,X,Y,Z,0)
+#define   DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVV,B,X,Y,Z,0)
+#define  DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVVV,B,X,Y,Z,0)
+#define         FLOATV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define        FLOATVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define       FLOATVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define      FLOATVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define     FLOATVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define    FLOATVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define   FLOATVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define           INTV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define          INTVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define         INTVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define        INTVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define       INTVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define      INTVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define     INTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define       LOGICALV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define      LOGICALVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define     LOGICALVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define    LOGICALVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define   LOGICALVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define  LOGICALVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define          LONGV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define         LONGVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define        LONGVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define       LONGVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define      LONGVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define     LONGVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define    LONGVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define         SHORTV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define        SHORTVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define       SHORTVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define      SHORTVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define     SHORTVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define    SHORTVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define   SHORTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define          PVOID_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,B,B,X,Y,Z,0)
+#define        ROUTINE_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+/*CRAY coughs on the first,
+  i.e. the usual trouble of not being able to
+  define macros to macros with arguments. 
+  New ultrix is worse, it coughs on all such uses.
+ */
+/*#define       SIMPLE_cfINT                    PVOID_cfINT*/
+#define         SIMPLE_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define           VOID_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define         STRING_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define        STRINGV_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define        PSTRING_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define       PSTRINGV_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define       PNSTRING_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define       PPSTRING_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define        ZTRINGV_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define       PZTRINGV_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define           CF_0_cfINT(N,A,B,X,Y,Z)
+                         
+
+#define   UCF(TN,I,C)  _SEP_(TN,C,cfCOMMA) _Icf(2,U,TN,_(A,I),0)
+#define  UUCF(TN,I,C)  _SEP_(TN,C,cfCOMMA) _SEP_(TN,1,I) 
+#define UUUCF(TN,I,C)  _SEP_(TN,C,cfCOLON) _Icf(2,U,TN,_(A,I),0)
+#define        INT_cfU(T,A) _(T,VVVVVVV_cfTYPE)   A
+#define       INTV_cfU(T,A) _(T,VVVVVV_cfTYPE)  * A
+#define      INTVV_cfU(T,A) _(T,VVVVV_cfTYPE)   * A
+#define     INTVVV_cfU(T,A) _(T,VVVV_cfTYPE)    * A
+#define    INTVVVV_cfU(T,A) _(T,VVV_cfTYPE)     * A
+#define   INTVVVVV_cfU(T,A) _(T,VV_cfTYPE)      * A
+#define  INTVVVVVV_cfU(T,A) _(T,V_cfTYPE)       * A
+#define INTVVVVVVV_cfU(T,A) _(T,_cfTYPE)        * A
+#define       PINT_cfU(T,A) _(T,_cfTYPE)        * A
+#define      PVOID_cfU(T,A) void  *A 
+#define    ROUTINE_cfU(T,A) void (*A)(CF_NULL_PROTO) 
+#define       VOID_cfU(T,A) void   A    /* Needed for C calls FORTRAN sub.s.  */
+#define     STRING_cfU(T,A) char  *A    /*            via VOID and wrapper.   */
+#define    STRINGV_cfU(T,A) char  *A
+#define    PSTRING_cfU(T,A) char  *A
+#define   PSTRINGV_cfU(T,A) char  *A
+#define    ZTRINGV_cfU(T,A) char  *A
+#define   PZTRINGV_cfU(T,A) char  *A
+
+/* VOID breaks U into U and UU. */
+#define       INT_cfUU(T,A) _(T,VVVVVVV_cfTYPE) A
+#define      VOID_cfUU(T,A)             /* Needed for FORTRAN calls C sub.s.  */
+#define    STRING_cfUU(T,A) char *A 
+
+
+#define      BYTE_cfPU(A)   CFextern INTEGER_BYTE      FCALLSC_QUALIFIER A
+#define    DOUBLE_cfPU(A)   CFextern DOUBLE_PRECISION  FCALLSC_QUALIFIER A
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define     FLOAT_cfPU(A)   CFextern FORTRAN_REAL      FCALLSC_QUALIFIER A
+#else				   	                   
+#define     FLOAT_cfPU(A)   CFextern FLOATFUNCTIONTYPE FCALLSC_QUALIFIER A
+#endif				   	                   
+#define       INT_cfPU(A)   CFextern int   FCALLSC_QUALIFIER   A
+#define   LOGICAL_cfPU(A)   CFextern int   FCALLSC_QUALIFIER   A
+#define      LONG_cfPU(A)   CFextern long  FCALLSC_QUALIFIER   A
+#define     SHORT_cfPU(A)   CFextern short FCALLSC_QUALIFIER   A
+#define    STRING_cfPU(A)   CFextern void  FCALLSC_QUALIFIER   A
+#define      VOID_cfPU(A)   CFextern void  FCALLSC_QUALIFIER   A
+
+#define    BYTE_cfE INTEGER_BYTE     A0;
+#define  DOUBLE_cfE DOUBLE_PRECISION A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define   FLOAT_cfE FORTRAN_REAL  A0;
+#else
+#define   FLOAT_cfE FORTRAN_REAL AA0;   FLOATFUNCTIONTYPE A0;
+#endif
+#define     INT_cfE int    A0;
+#define LOGICAL_cfE int    A0;
+#define    LONG_cfE long   A0;
+#define   SHORT_cfE short  A0;
+#define    VOID_cfE
+#ifdef vmsFortran
+#define  STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING];        \
+                       static fstring A0 =                                     \
+             {MAX_LEN_FORTRAN_FUNCTION_STRING,DSC$K_DTYPE_T,DSC$K_CLASS_S,AA0};\
+               memset(AA0, CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\
+                                    *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
+#else
+#ifdef CRAYFortran
+#define  STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING];        \
+                   static _fcd A0; *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';\
+                memset(AA0,CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\
+                            A0 = _cptofcd(AA0,MAX_LEN_FORTRAN_FUNCTION_STRING);
+#else
+/* 'cc: SC3.0.1 13 Jul 1994' barfs on char A0[0x4FE+1]; 
+ * char A0[0x4FE +1]; char A0[1+0x4FE]; are both OK.     */
+#define STRING_cfE static char A0[1+MAX_LEN_FORTRAN_FUNCTION_STRING];          \
+                       memset(A0, CFORTRAN_NON_CHAR,                           \
+                              MAX_LEN_FORTRAN_FUNCTION_STRING);                \
+                       *(A0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
+#endif
+#endif
+/* ESTRING must use static char. array which is guaranteed to exist after
+   function returns.                                                     */
+
+/* N.B.i) The diff. for 0 (Zero) and >=1 arguments.
+       ii)That the following create an unmatched bracket, i.e. '(', which
+          must of course be matched in the call.
+       iii)Commas must be handled very carefully                         */
+#define    INT_cfGZ(T,UN,LN) A0=CFC_(UN,LN)(
+#define   VOID_cfGZ(T,UN,LN)    CFC_(UN,LN)(
+#ifdef vmsFortran
+#define STRING_cfGZ(T,UN,LN)    CFC_(UN,LN)(&A0
+#else
+#if defined(CRAYFortran) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define STRING_cfGZ(T,UN,LN)    CFC_(UN,LN)( A0
+#else
+#define STRING_cfGZ(T,UN,LN)    CFC_(UN,LN)( A0,MAX_LEN_FORTRAN_FUNCTION_STRING
+#endif
+#endif
+
+#define     INT_cfG(T,UN,LN)    INT_cfGZ(T,UN,LN)
+#define    VOID_cfG(T,UN,LN)   VOID_cfGZ(T,UN,LN)
+#define  STRING_cfG(T,UN,LN) STRING_cfGZ(T,UN,LN), /*, is only diff. from _cfG*/
+
+#define    BYTEVVVVVVV_cfPP
+#define     INTVVVVVVV_cfPP     /* These complement FLOATVVVVVVV_cfPP. */
+#define  DOUBLEVVVVVVV_cfPP
+#define LOGICALVVVVVVV_cfPP
+#define    LONGVVVVVVV_cfPP
+#define   SHORTVVVVVVV_cfPP
+#define          PBYTE_cfPP
+#define           PINT_cfPP
+#define        PDOUBLE_cfPP
+#define       PLOGICAL_cfPP
+#define          PLONG_cfPP
+#define         PSHORT_cfPP
+#define         PFLOAT_cfPP FLOATVVVVVVV_cfPP
+
+#define BCF(TN,AN,C)        _SEP_(TN,C,cfCOMMA) _Icf(2,B,TN,AN,0)
+#define        INT_cfB(T,A) (_(T,VVVVVVV_cfTYPE)) A
+#define       INTV_cfB(T,A)            A
+#define      INTVV_cfB(T,A)           (A)[0]
+#define     INTVVV_cfB(T,A)           (A)[0][0]
+#define    INTVVVV_cfB(T,A)           (A)[0][0][0]
+#define   INTVVVVV_cfB(T,A)           (A)[0][0][0][0]
+#define  INTVVVVVV_cfB(T,A)           (A)[0][0][0][0][0]
+#define INTVVVVVVV_cfB(T,A)           (A)[0][0][0][0][0][0]
+#define       PINT_cfB(T,A) _(T,_cfPP)&A
+#define     STRING_cfB(T,A) (char *)   A
+#define    STRINGV_cfB(T,A) (char *)   A
+#define    PSTRING_cfB(T,A) (char *)   A
+#define   PSTRINGV_cfB(T,A) (char *)   A
+#define      PVOID_cfB(T,A) (void *)   A
+#define    ROUTINE_cfB(T,A) (cfCAST_FUNCTION)A
+#define    ZTRINGV_cfB(T,A) (char *)   A
+#define   PZTRINGV_cfB(T,A) (char *)   A
+                                                              	
+#define SCF(TN,NAME,I,A)    _(TN,_cfSTR)(3,S,NAME,I,A,0,0)
+#define  DEFAULT_cfS(M,I,A)
+#define  LOGICAL_cfS(M,I,A)
+#define PLOGICAL_cfS(M,I,A)
+#define   STRING_cfS(M,I,A) ,sizeof(A)
+#define  STRINGV_cfS(M,I,A) ,( (unsigned)0xFFFF*firstindexlength(A) \
+                              +secondindexlength(A))
+#define  PSTRING_cfS(M,I,A) ,sizeof(A)
+#define PSTRINGV_cfS(M,I,A) STRINGV_cfS(M,I,A)
+#define  ZTRINGV_cfS(M,I,A)
+#define PZTRINGV_cfS(M,I,A)
+
+#define   HCF(TN,I)         _(TN,_cfSTR)(3,H,cfCOMMA, H,_(C,I),0,0)
+#define  HHCF(TN,I)         _(TN,_cfSTR)(3,H,cfCOMMA,HH,_(C,I),0,0)
+#define HHHCF(TN,I)         _(TN,_cfSTR)(3,H,cfCOLON, H,_(C,I),0,0)
+#define  H_CF_SPECIAL       unsigned
+#define HH_CF_SPECIAL
+#define  DEFAULT_cfH(M,I,A)
+#define  LOGICAL_cfH(S,U,B)
+#define PLOGICAL_cfH(S,U,B)
+#define   STRING_cfH(S,U,B) _(A,S) _(U,_CF_SPECIAL) B
+#define  STRINGV_cfH(S,U,B) STRING_cfH(S,U,B)
+#define  PSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PSTRINGV_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PNSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PPSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define  ZTRINGV_cfH(S,U,B)
+#define PZTRINGV_cfH(S,U,B)
+
+/* Need VOID_cfSTR because Absoft forced function types go through _cfSTR. */
+/* No spaces inside expansion. They screws up macro catenation kludge.     */
+#define           VOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define           BYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         DOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          FLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define            INT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        LOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LOGICAL,A,B,C,D,E)
+#define           LONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          SHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          BYTEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         BYTEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        BYTEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       BYTEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      BYTEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     BYTEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    BYTEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        DOUBLEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       DOUBLEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      DOUBLEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     DOUBLEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    DOUBLEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define   DOUBLEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define  DOUBLEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         FLOATV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        FLOATVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       FLOATVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      FLOATVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     FLOATVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    FLOATVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define   FLOATVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define           INTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          INTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         INTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        INTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       INTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      INTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     INTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       LOGICALV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      LOGICALVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     LOGICALVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    LOGICALVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define   LOGICALVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define  LOGICALVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          LONGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         LONGVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        LONGVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       LONGVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      LONGVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     LONGVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    LONGVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         SHORTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        SHORTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       SHORTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      SHORTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     SHORTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    SHORTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define   SHORTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          PBYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        PDOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         PFLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define           PINT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       PLOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PLOGICAL,A,B,C,D,E)
+#define          PLONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         PSHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         STRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRING,A,B,C,D,E)
+#define        PSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRING,A,B,C,D,E)
+#define        STRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRINGV,A,B,C,D,E)
+#define       PSTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRINGV,A,B,C,D,E)
+#define       PNSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PNSTRING,A,B,C,D,E)
+#define       PPSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PPSTRING,A,B,C,D,E)
+#define          PVOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        ROUTINE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         SIMPLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        ZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,ZTRINGV,A,B,C,D,E)
+#define       PZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PZTRINGV,A,B,C,D,E)
+#define           CF_0_cfSTR(N,T,A,B,C,D,E)
+
+/* See ACF table comments, which explain why CCF was split into two. */
+#define CCF(NAME,TN,I)     _(TN,_cfSTR)(5,C,NAME,I,_(A,I),_(B,I),_(C,I))
+#define  DEFAULT_cfC(M,I,A,B,C)
+#define  LOGICAL_cfC(M,I,A,B,C)  A=C2FLOGICAL( A);
+#define PLOGICAL_cfC(M,I,A,B,C) *A=C2FLOGICAL(*A);
+#ifdef vmsFortran
+#define   STRING_cfC(M,I,A,B,C) (B.clen=strlen(A),B.f.dsc$a_pointer=A,         \
+        C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.f.dsc$w_length=B.clen:     \
+          (memset((A)+B.clen,' ',C-B.clen-1),A[B.f.dsc$w_length=C-1]='\0'));
+      /* PSTRING_cfC to beware of array A which does not contain any \0.      */
+#define  PSTRING_cfC(M,I,A,B,C) (B.dsc$a_pointer=A, C==sizeof(char*) ?         \
+             B.dsc$w_length=strlen(A):  (A[C-1]='\0',B.dsc$w_length=strlen(A), \
+       memset((A)+B.dsc$w_length,' ',C-B.dsc$w_length-1), B.dsc$w_length=C-1));
+#else
+#define   STRING_cfC(M,I,A,B,C) (B.nombre=A,B.clen=strlen(A),                             \
+                C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.flen=B.clen:       \
+                        (memset(B.nombre+B.clen,' ',C-B.clen-1),B.nombre[B.flen=C-1]='\0'));
+#define  PSTRING_cfC(M,I,A,B,C) (C==sizeof(char*)? B=strlen(A):                \
+                    (A[C-1]='\0',B=strlen(A),memset((A)+B,' ',C-B-1),B=C-1));
+#endif
+          /* For CRAYFortran for (P)STRINGV_cfC, B.fs is set, but irrelevant. */
+#define  STRINGV_cfC(M,I,A,B,C) \
+        AATRINGV_cfA(    A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF)
+#define PSTRINGV_cfC(M,I,A,B,C) \
+       APATRINGV_cfA(    A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF)
+#define  ZTRINGV_cfC(M,I,A,B,C) \
+        AATRINGV_cfA(    A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1),       \
+                              (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1   )
+#define PZTRINGV_cfC(M,I,A,B,C) \
+       APATRINGV_cfA(    A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1),       \
+                              (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1   )
+
+#define     BYTE_cfCCC(A,B) &A
+#define   DOUBLE_cfCCC(A,B) &A
+#if !defined(__CF__KnR)
+#define    FLOAT_cfCCC(A,B) &A
+                               /* Although the VAX doesn't, at least the      */
+#else                          /* HP and K&R mips promote float arg.'s of     */
+#define    FLOAT_cfCCC(A,B) &B /* unprototyped functions to double. Cannot    */
+#endif                         /* use A here to pass the argument to FORTRAN. */
+#define      INT_cfCCC(A,B) &A
+#define  LOGICAL_cfCCC(A,B) &A
+#define     LONG_cfCCC(A,B) &A
+#define    SHORT_cfCCC(A,B) &A
+#define    PBYTE_cfCCC(A,B)  A
+#define  PDOUBLE_cfCCC(A,B)  A
+#define   PFLOAT_cfCCC(A,B)  A
+#define     PINT_cfCCC(A,B)  A
+#define PLOGICAL_cfCCC(A,B)  B=A       /* B used to keep a common W table. */
+#define    PLONG_cfCCC(A,B)  A
+#define   PSHORT_cfCCC(A,B)  A
+
+#define CCCF(TN,I,M)           _SEP_(TN,M,cfCOMMA) _Icf(3,CC,TN,_(A,I),_(B,I))
+#define        INT_cfCC(T,A,B) _(T,_cfCCC)(A,B) 
+#define       INTV_cfCC(T,A,B)  A
+#define      INTVV_cfCC(T,A,B)  A
+#define     INTVVV_cfCC(T,A,B)  A
+#define    INTVVVV_cfCC(T,A,B)  A
+#define   INTVVVVV_cfCC(T,A,B)  A
+#define  INTVVVVVV_cfCC(T,A,B)  A
+#define INTVVVVVVV_cfCC(T,A,B)  A
+#define       PINT_cfCC(T,A,B) _(T,_cfCCC)(A,B) 
+#define      PVOID_cfCC(T,A,B)  A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define    ROUTINE_cfCC(T,A,B) &A
+#else
+#define    ROUTINE_cfCC(T,A,B)  A
+#endif
+#define     SIMPLE_cfCC(T,A,B)  A
+#ifdef vmsFortran
+#define     STRING_cfCC(T,A,B) &B.f
+#define    STRINGV_cfCC(T,A,B) &B
+#define    PSTRING_cfCC(T,A,B) &B
+#define   PSTRINGV_cfCC(T,A,B) &B
+#else
+#ifdef CRAYFortran
+#define     STRING_cfCC(T,A,B) _cptofcd(A,B.flen)
+#define    STRINGV_cfCC(T,A,B) _cptofcd(B.s,B.flen)
+#define    PSTRING_cfCC(T,A,B) _cptofcd(A,B)
+#define   PSTRINGV_cfCC(T,A,B) _cptofcd(A,B.flen)
+#else
+#define     STRING_cfCC(T,A,B)  A
+#define    STRINGV_cfCC(T,A,B)  B.fs
+#define    PSTRING_cfCC(T,A,B)  A
+#define   PSTRINGV_cfCC(T,A,B)  B.fs
+#endif
+#endif
+#define    ZTRINGV_cfCC(T,A,B)   STRINGV_cfCC(T,A,B)
+#define   PZTRINGV_cfCC(T,A,B)  PSTRINGV_cfCC(T,A,B)
+
+#define    BYTE_cfX  return A0;
+#define  DOUBLE_cfX  return A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define   FLOAT_cfX  return A0;
+#else
+#define   FLOAT_cfX  ASSIGNFLOAT(AA0,A0); return AA0;
+#endif
+#define     INT_cfX  return A0;
+#define LOGICAL_cfX  return F2CLOGICAL(A0);
+#define    LONG_cfX  return A0;
+#define   SHORT_cfX  return A0;
+#define    VOID_cfX  return   ;
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define  STRING_cfX  return kill_trailing(                                     \
+                                      kill_trailing(AA0,CFORTRAN_NON_CHAR),' ');
+#else
+#define  STRING_cfX  return kill_trailing(                                     \
+                                      kill_trailing( A0,CFORTRAN_NON_CHAR),' ');
+#endif
+
+#define CFFUN(NAME) _(__cf__,NAME)
+
+/* Note that we don't use LN here, but we keep it for consistency. */
+#define CCALLSFFUN0(UN,LN) CFFUN(UN)()
+
+#ifdef OLD_VAXC                                  /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+#define CCALLSFFUN1( UN,LN,T1,                        A1)         \
+        CCALLSFFUN5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0)
+#define CCALLSFFUN2( UN,LN,T1,T2,                     A1,A2)      \
+        CCALLSFFUN5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0)
+#define CCALLSFFUN3( UN,LN,T1,T2,T3,                  A1,A2,A3)   \
+        CCALLSFFUN5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0)
+#define CCALLSFFUN4( UN,LN,T1,T2,T3,T4,               A1,A2,A3,A4)\
+        CCALLSFFUN5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0)
+#define CCALLSFFUN5( UN,LN,T1,T2,T3,T4,T5,            A1,A2,A3,A4,A5)          \
+        CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0)
+#define CCALLSFFUN6( UN,LN,T1,T2,T3,T4,T5,T6,         A1,A2,A3,A4,A5,A6)       \
+        CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0)
+#define CCALLSFFUN7( UN,LN,T1,T2,T3,T4,T5,T6,T7,      A1,A2,A3,A4,A5,A6,A7)    \
+        CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0)
+#define CCALLSFFUN8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,   A1,A2,A3,A4,A5,A6,A7,A8) \
+        CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0)
+#define CCALLSFFUN9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\
+        CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0)
+#define CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\
+        CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0)
+#define CCALLSFFUN11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\
+        CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0)
+#define CCALLSFFUN12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\
+        CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0)
+#define CCALLSFFUN13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\
+        CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0)
+
+#define CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+((CFFUN(UN)(  BCF(T1,A1,0) BCF(T2,A2,1) BCF(T3,A3,1) BCF(T4,A4,1) BCF(T5,A5,1) \
+              BCF(T6,A6,1) BCF(T7,A7,1) BCF(T8,A8,1) BCF(T9,A9,1) BCF(TA,AA,1) \
+              BCF(TB,AB,1) BCF(TC,AC,1) BCF(TD,AD,1) BCF(TE,AE,1)              \
+           SCF(T1,LN,1,A1)  SCF(T2,LN,2,A2)  SCF(T3,LN,3,A3)  SCF(T4,LN,4,A4)  \
+           SCF(T5,LN,5,A5)  SCF(T6,LN,6,A6)  SCF(T7,LN,7,A7)  SCF(T8,LN,8,A8)  \
+           SCF(T9,LN,9,A9)  SCF(TA,LN,10,AA) SCF(TB,LN,11,AB) SCF(TC,LN,12,AC) \
+           SCF(TD,LN,13,AD) SCF(TE,LN,14,AE))))
+
+/*  N.B. Create a separate function instead of using (call function, function
+value here) because in order to create the variables needed for the input
+arg.'s which may be const.'s one has to do the creation within {}, but these
+can never be placed within ()'s. Therefore one must create wrapper functions.
+gcc, on the other hand may be able to avoid the wrapper functions. */
+
+/* Prototypes are needed to correctly handle the value returned correctly. N.B.
+Can only have prototype arg.'s with difficulty, a la G... table since FORTRAN
+functions returning strings have extra arg.'s. Don't bother, since this only
+causes a compiler warning to come up when one uses FCALLSCFUNn and CCALLSFFUNn
+for the same function in the same source code. Something done by the experts in
+debugging only.*/    
+
+#define PROTOCCALLSFFUN0(F,UN,LN)                                              \
+_(F,_cfPU)( CFC_(UN,LN))(CF_NULL_PROTO);                                       \
+static _Icf(2,U,F,CFFUN(UN),0)() {_(F,_cfE) _Icf(3,GZ,F,UN,LN) ABSOFT_cf1(F));_(F,_cfX)}
+
+#define PROTOCCALLSFFUN1( T0,UN,LN,T1)                                         \
+        PROTOCCALLSFFUN5 (T0,UN,LN,T1,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN2( T0,UN,LN,T1,T2)                                      \
+        PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN3( T0,UN,LN,T1,T2,T3)                                   \
+        PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,CF_0,CF_0)
+#define PROTOCCALLSFFUN4( T0,UN,LN,T1,T2,T3,T4)                                \
+        PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,T4,CF_0)
+#define PROTOCCALLSFFUN5( T0,UN,LN,T1,T2,T3,T4,T5)                             \
+        PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN6( T0,UN,LN,T1,T2,T3,T4,T5,T6)                          \
+        PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN7( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7)                       \
+        PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN8( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8)                    \
+        PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0)
+#define PROTOCCALLSFFUN9( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9)                 \
+        PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0)
+#define PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA)              \
+        PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN11(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB)           \
+        PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN12(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC)        \
+        PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define PROTOCCALLSFFUN13(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD)     \
+        PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+/* HP/UX 9.01 cc requires the blank between '_Icf(3,G,T0,UN,LN) CCCF(T1,1,0)' */
+
+#ifndef __CF__KnR
+#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)  \
+ _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)(     \
+   CFARGT14FS(UCF,HCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) )          \
+{       CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    _(T0,_cfE) \
+ CCF(LN,T1,1)  CCF(LN,T2,2)  CCF(LN,T3,3)  CCF(LN,T4,4)  CCF(LN,T5,5)          \
+ CCF(LN,T6,6)  CCF(LN,T7,7)  CCF(LN,T8,8)  CCF(LN,T9,9)  CCF(LN,TA,10)         \
+ CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14)    _Icf(3,G,T0,UN,LN) \
+ CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \
+ WCF(T1,A1,1)   WCF(T2,A2,2)   WCF(T3,A3,3)   WCF(T4,A4,4)  WCF(T5,A5,5)       \
+ WCF(T6,A6,6)   WCF(T7,A7,7)   WCF(T8,A8,8)   WCF(T9,A9,9)  WCF(TA,A10,10)     \
+ WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)}
+#else
+#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)  \
+ _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)(     \
+   CFARGT14FS(UUCF,HHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) )        \
+ CFARGT14FS(UUUCF,HHHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ;        \
+{       CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    _(T0,_cfE) \
+ CCF(LN,T1,1)  CCF(LN,T2,2)  CCF(LN,T3,3)  CCF(LN,T4,4)  CCF(LN,T5,5)          \
+ CCF(LN,T6,6)  CCF(LN,T7,7)  CCF(LN,T8,8)  CCF(LN,T9,9)  CCF(LN,TA,10)         \
+ CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14)    _Icf(3,G,T0,UN,LN) \
+ CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \
+ WCF(T1,A1,1)   WCF(T2,A2,2)   WCF(T3,A3,3)   WCF(T4,A4,4)   WCF(T5,A5,5)      \
+ WCF(T6,A6,6)   WCF(T7,A7,7)   WCF(T8,A8,8)   WCF(T9,A9,9)   WCF(TA,A10,10)    \
+ WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)}
+#endif
+
+/*-------------------------------------------------------------------------*/
+
+/*               UTILITIES FOR FORTRAN TO CALL C ROUTINES                  */
+
+#ifdef OLD_VAXC                                /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define   DCF(TN,I)
+#define  DDCF(TN,I)
+#define DDDCF(TN,I)
+#else
+#define   DCF(TN,I)          HCF(TN,I)
+#define  DDCF(TN,I)         HHCF(TN,I)
+#define DDDCF(TN,I)        HHHCF(TN,I)
+#endif
+
+#define QCF(TN,I)       _(TN,_cfSTR)(1,Q,_(B,I), 0,0,0,0)
+#define  DEFAULT_cfQ(B)
+#define  LOGICAL_cfQ(B)
+#define PLOGICAL_cfQ(B)
+#define  STRINGV_cfQ(B) char *B; unsigned int _(B,N);
+#define   STRING_cfQ(B) char *B=NULL;
+#define  PSTRING_cfQ(B) char *B=NULL;
+#define PSTRINGV_cfQ(B) STRINGV_cfQ(B)
+#define PNSTRING_cfQ(B) char *B=NULL;
+#define PPSTRING_cfQ(B)
+
+#ifdef     __sgi   /* Else SGI gives warning 182 contrary to its C LRM A.17.7 */
+#define ROUTINE_orig    *(void**)& 
+#else
+#define ROUTINE_orig     (void *)  
+#endif
+
+#define ROUTINE_1     ROUTINE_orig   
+#define ROUTINE_2     ROUTINE_orig   
+#define ROUTINE_3     ROUTINE_orig   
+#define ROUTINE_4     ROUTINE_orig   
+#define ROUTINE_5     ROUTINE_orig   
+#define ROUTINE_6     ROUTINE_orig   
+#define ROUTINE_7     ROUTINE_orig   
+#define ROUTINE_8     ROUTINE_orig   
+#define ROUTINE_9     ROUTINE_orig   
+#define ROUTINE_10    ROUTINE_orig   
+#define ROUTINE_11    ROUTINE_orig   
+#define ROUTINE_12    ROUTINE_orig   
+#define ROUTINE_13    ROUTINE_orig   
+#define ROUTINE_14    ROUTINE_orig   
+#define ROUTINE_15    ROUTINE_orig   
+#define ROUTINE_16    ROUTINE_orig   
+#define ROUTINE_17    ROUTINE_orig   
+#define ROUTINE_18    ROUTINE_orig   
+#define ROUTINE_19    ROUTINE_orig   
+#define ROUTINE_20    ROUTINE_orig   
+#define ROUTINE_21    ROUTINE_orig   
+#define ROUTINE_22    ROUTINE_orig   
+#define ROUTINE_23    ROUTINE_orig   
+#define ROUTINE_24    ROUTINE_orig   
+#define ROUTINE_25    ROUTINE_orig   
+#define ROUTINE_26    ROUTINE_orig   
+#define ROUTINE_27    ROUTINE_orig   
+
+#define TCF(NAME,TN,I,M)              _SEP_(TN,M,cfCOMMA) _(TN,_cfT)(NAME,I,_(A,I),_(B,I),_(C,I))
+#define           BYTE_cfT(M,I,A,B,D) *A
+#define         DOUBLE_cfT(M,I,A,B,D) *A
+#define          FLOAT_cfT(M,I,A,B,D) *A
+#define            INT_cfT(M,I,A,B,D) *A
+#define        LOGICAL_cfT(M,I,A,B,D)  F2CLOGICAL(*A)
+#define           LONG_cfT(M,I,A,B,D) *A
+#define          SHORT_cfT(M,I,A,B,D) *A
+#define          BYTEV_cfT(M,I,A,B,D)  A
+#define        DOUBLEV_cfT(M,I,A,B,D)  A
+#define         FLOATV_cfT(M,I,A,B,D)  VOIDP A
+#define           INTV_cfT(M,I,A,B,D)  A
+#define       LOGICALV_cfT(M,I,A,B,D)  A
+#define          LONGV_cfT(M,I,A,B,D)  A
+#define         SHORTV_cfT(M,I,A,B,D)  A
+#define         BYTEVV_cfT(M,I,A,B,D)  (void *)A /* We have to cast to void *,*/
+#define        BYTEVVV_cfT(M,I,A,B,D)  (void *)A /* since we don't know the   */
+#define       BYTEVVVV_cfT(M,I,A,B,D)  (void *)A /* dimensions of the array.  */
+#define      BYTEVVVVV_cfT(M,I,A,B,D)  (void *)A /* i.e. Unfortunately, can't */
+#define     BYTEVVVVVV_cfT(M,I,A,B,D)  (void *)A /* check that the type       */
+#define    BYTEVVVVVVV_cfT(M,I,A,B,D)  (void *)A /* matches the prototype.    */
+#define       DOUBLEVV_cfT(M,I,A,B,D)  (void *)A
+#define      DOUBLEVVV_cfT(M,I,A,B,D)  (void *)A
+#define     DOUBLEVVVV_cfT(M,I,A,B,D)  (void *)A
+#define    DOUBLEVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define   DOUBLEVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define  DOUBLEVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define        FLOATVV_cfT(M,I,A,B,D)  (void *)A
+#define       FLOATVVV_cfT(M,I,A,B,D)  (void *)A
+#define      FLOATVVVV_cfT(M,I,A,B,D)  (void *)A
+#define     FLOATVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define    FLOATVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define   FLOATVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define          INTVV_cfT(M,I,A,B,D)  (void *)A  
+#define         INTVVV_cfT(M,I,A,B,D)  (void *)A  
+#define        INTVVVV_cfT(M,I,A,B,D)  (void *)A  
+#define       INTVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define      INTVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define     INTVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define      LOGICALVV_cfT(M,I,A,B,D)  (void *)A
+#define     LOGICALVVV_cfT(M,I,A,B,D)  (void *)A
+#define    LOGICALVVVV_cfT(M,I,A,B,D)  (void *)A
+#define   LOGICALVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define  LOGICALVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define LOGICALVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define         LONGVV_cfT(M,I,A,B,D)  (void *)A
+#define        LONGVVV_cfT(M,I,A,B,D)  (void *)A
+#define       LONGVVVV_cfT(M,I,A,B,D)  (void *)A
+#define      LONGVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define     LONGVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define    LONGVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define        SHORTVV_cfT(M,I,A,B,D)  (void *)A
+#define       SHORTVVV_cfT(M,I,A,B,D)  (void *)A
+#define      SHORTVVVV_cfT(M,I,A,B,D)  (void *)A
+#define     SHORTVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define    SHORTVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define   SHORTVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define          PBYTE_cfT(M,I,A,B,D)  A
+#define        PDOUBLE_cfT(M,I,A,B,D)  A
+#define         PFLOAT_cfT(M,I,A,B,D)  VOIDP A
+#define           PINT_cfT(M,I,A,B,D)  A
+#define       PLOGICAL_cfT(M,I,A,B,D)  ((*A=F2CLOGICAL(*A)),A)
+#define          PLONG_cfT(M,I,A,B,D)  A
+#define         PSHORT_cfT(M,I,A,B,D)  A
+#define          PVOID_cfT(M,I,A,B,D)  A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define        ROUTINE_cfT(M,I,A,B,D)  _(ROUTINE_,I)  (*A)
+#else
+#define        ROUTINE_cfT(M,I,A,B,D)  _(ROUTINE_,I)    A
+#endif
+/* A == pointer to the characters
+   D == length of the string, or of an element in an array of strings
+   E == number of elements in an array of strings                             */
+#define TTSTR(    A,B,D)                                                       \
+           ((B=_cf_malloc(D+1))[D]='\0', memcpy(B,A,D), kill_trailing(B,' '))
+#define TTTTSTR(  A,B,D)   (!(D<4||A[0]||A[1]||A[2]||A[3]))?NULL:              \
+                            memchr(A,'\0',D)                 ?A   : TTSTR(A,B,D)
+#define TTTTSTRV( A,B,D,E) (_(B,N)=E,B=_cf_malloc(_(B,N)*(D+1)), (void *)      \
+  vkill_trailing(f2cstrv(A,B,D+1, _(B,N)*(D+1)), D+1,_(B,N)*(D+1),' '))
+#ifdef vmsFortran
+#define         STRING_cfT(M,I,A,B,D)  TTTTSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define        STRINGV_cfT(M,I,A,B,D)  TTTTSTRV(A->dsc$a_pointer, B,           \
+                                             A->dsc$w_length , A->dsc$l_m[0])
+#define        PSTRING_cfT(M,I,A,B,D)    TTSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define       PPSTRING_cfT(M,I,A,B,D)           A->dsc$a_pointer
+#else
+#ifdef CRAYFortran
+#define         STRING_cfT(M,I,A,B,D)  TTTTSTR( _fcdtocp(A),B,_fcdlen(A))
+#define        STRINGV_cfT(M,I,A,B,D)  TTTTSTRV(_fcdtocp(A),B,_fcdlen(A),      \
+                              num_elem(_fcdtocp(A),_fcdlen(A),_3(M,_STRV_A,I)))
+#define        PSTRING_cfT(M,I,A,B,D)    TTSTR( _fcdtocp(A),B,_fcdlen(A))
+#define       PPSTRING_cfT(M,I,A,B,D)           _fcdtocp(A)
+#else
+#define         STRING_cfT(M,I,A,B,D)  TTTTSTR( A,B,D)
+#define        STRINGV_cfT(M,I,A,B,D)  TTTTSTRV(A,B,D, num_elem(A,D,_3(M,_STRV_A,I)))
+#define        PSTRING_cfT(M,I,A,B,D)    TTSTR( A,B,D)
+#define       PPSTRING_cfT(M,I,A,B,D)           A
+#endif
+#endif
+#define       PNSTRING_cfT(M,I,A,B,D)    STRING_cfT(M,I,A,B,D)
+#define       PSTRINGV_cfT(M,I,A,B,D)   STRINGV_cfT(M,I,A,B,D)
+#define           CF_0_cfT(M,I,A,B,D)
+
+#define RCF(TN,I)           _(TN,_cfSTR)(3,R,_(A,I),_(B,I),_(C,I),0,0)
+#define  DEFAULT_cfR(A,B,D)
+#define  LOGICAL_cfR(A,B,D)
+#define PLOGICAL_cfR(A,B,D) *A=C2FLOGICAL(*A);
+#define   STRING_cfR(A,B,D) if (B) _cf_free(B);
+#define  STRINGV_cfR(A,B,D) _cf_free(B);
+/* A and D as defined above for TSTRING(V) */
+#define RRRRPSTR( A,B,D)    if (B) memcpy(A,B, _cfMIN(strlen(B),D)),           \
+                  (D>strlen(B)?memset(A+strlen(B),' ', D-strlen(B)):0), _cf_free(B);
+#define RRRRPSTRV(A,B,D)    c2fstrv(B,A,D+1,(D+1)*_(B,N)), _cf_free(B);
+#ifdef vmsFortran
+#define  PSTRING_cfR(A,B,D) RRRRPSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A->dsc$a_pointer,B,A->dsc$w_length)
+#else
+#ifdef CRAYFortran
+#define  PSTRING_cfR(A,B,D) RRRRPSTR( _fcdtocp(A),B,_fcdlen(A))
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(_fcdtocp(A),B,_fcdlen(A))
+#else
+#define  PSTRING_cfR(A,B,D) RRRRPSTR( A,B,D)
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A,B,D)
+#endif
+#endif
+#define PNSTRING_cfR(A,B,D) PSTRING_cfR(A,B,D)
+#define PPSTRING_cfR(A,B,D)
+
+#define    BYTE_cfFZ(UN,LN) INTEGER_BYTE     FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define  DOUBLE_cfFZ(UN,LN) DOUBLE_PRECISION FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define     INT_cfFZ(UN,LN) int   FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define LOGICAL_cfFZ(UN,LN) int   FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define    LONG_cfFZ(UN,LN) long  FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define   SHORT_cfFZ(UN,LN) short FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define    VOID_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#ifndef __CF__KnR
+/* The void is req'd by the Apollo, to make this an ANSI function declaration.
+   The Apollo promotes K&R float functions to double. */
+#define   FLOAT_cfFZ(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(void
+#ifdef vmsFortran
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(fstring *AS
+#else
+#ifdef CRAYFortran
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(_fcd     AS
+#else
+#if  defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(char    *AS
+#else
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(char    *AS, unsigned D0
+#endif
+#endif
+#endif
+#else
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define   FLOAT_cfFZ(UN,LN) FORTRAN_REAL      FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#else
+#define   FLOAT_cfFZ(UN,LN) FLOATFUNCTIONTYPE FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#endif
+#if defined(vmsFortran) || defined(CRAYFortran) || defined(AbsoftUNIXFortran)
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(AS
+#else
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(AS, D0
+#endif
+#endif
+
+#define    BYTE_cfF(UN,LN)     BYTE_cfFZ(UN,LN)
+#define  DOUBLE_cfF(UN,LN)   DOUBLE_cfFZ(UN,LN)
+#ifndef __CF_KnR
+#define   FLOAT_cfF(UN,LN)  FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#else
+#define   FLOAT_cfF(UN,LN)    FLOAT_cfFZ(UN,LN)
+#endif
+#define     INT_cfF(UN,LN)      INT_cfFZ(UN,LN)
+#define LOGICAL_cfF(UN,LN)  LOGICAL_cfFZ(UN,LN)
+#define    LONG_cfF(UN,LN)     LONG_cfFZ(UN,LN)
+#define   SHORT_cfF(UN,LN)    SHORT_cfFZ(UN,LN)
+#define    VOID_cfF(UN,LN)     VOID_cfFZ(UN,LN)
+#define  STRING_cfF(UN,LN)   STRING_cfFZ(UN,LN),
+
+#define     INT_cfFF
+#define    VOID_cfFF
+#ifdef vmsFortran
+#define  STRING_cfFF           fstring *AS; 
+#else
+#ifdef CRAYFortran
+#define  STRING_cfFF           _fcd     AS;
+#else
+#define  STRING_cfFF           char    *AS; unsigned D0;
+#endif
+#endif
+
+#define     INT_cfL            A0=
+#define  STRING_cfL            A0=
+#define    VOID_cfL                        
+
+#define    INT_cfK
+#define   VOID_cfK
+/* KSTRING copies the string into the position provided by the caller. */
+#ifdef vmsFortran
+#define STRING_cfK                                                             \
+ memcpy(AS->dsc$a_pointer,A0,_cfMIN(AS->dsc$w_length,(A0==NULL?0:strlen(A0))));\
+ AS->dsc$w_length>(A0==NULL?0:strlen(A0))?                                     \
+  memset(AS->dsc$a_pointer+(A0==NULL?0:strlen(A0)),' ',                        \
+         AS->dsc$w_length-(A0==NULL?0:strlen(A0))):0;
+#else
+#ifdef CRAYFortran
+#define STRING_cfK                                                             \
+ memcpy(_fcdtocp(AS),A0, _cfMIN(_fcdlen(AS),(A0==NULL?0:strlen(A0))) );        \
+ _fcdlen(AS)>(A0==NULL?0:strlen(A0))?                                          \
+  memset(_fcdtocp(AS)+(A0==NULL?0:strlen(A0)),' ',                             \
+         _fcdlen(AS)-(A0==NULL?0:strlen(A0))):0;
+#else
+#define STRING_cfK         memcpy(AS,A0, _cfMIN(D0,(A0==NULL?0:strlen(A0))) ); \
+                 D0>(A0==NULL?0:strlen(A0))?memset(AS+(A0==NULL?0:strlen(A0)), \
+                                            ' ', D0-(A0==NULL?0:strlen(A0))):0;
+#endif
+#endif
+
+/* Note that K.. and I.. can't be combined since K.. has to access data before
+R.., in order for functions returning strings which are also passed in as
+arguments to work correctly. Note that R.. frees and hence may corrupt the
+string. */
+#define    BYTE_cfI  return A0;
+#define  DOUBLE_cfI  return A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define   FLOAT_cfI  return A0;
+#else
+#define   FLOAT_cfI  RETURNFLOAT(A0);
+#endif
+#define     INT_cfI  return A0;
+#ifdef hpuxFortran800
+/* Incredibly, functions must return true as 1, elsewhere .true.==0x01000000. */
+#define LOGICAL_cfI  return ((A0)?1:0);
+#else
+#define LOGICAL_cfI  return C2FLOGICAL(A0);
+#endif
+#define    LONG_cfI  return A0;
+#define   SHORT_cfI  return A0;
+#define  STRING_cfI  return   ;
+#define    VOID_cfI  return   ;
+
+#ifdef OLD_VAXC                                  /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+#define FCALLSCSUB0( CN,UN,LN)             FCALLSCFUN0(VOID,CN,UN,LN)
+#define FCALLSCSUB1( CN,UN,LN,T1)          FCALLSCFUN1(VOID,CN,UN,LN,T1)
+#define FCALLSCSUB2( CN,UN,LN,T1,T2)       FCALLSCFUN2(VOID,CN,UN,LN,T1,T2)
+#define FCALLSCSUB3( CN,UN,LN,T1,T2,T3)    FCALLSCFUN3(VOID,CN,UN,LN,T1,T2,T3)
+#define FCALLSCSUB4( CN,UN,LN,T1,T2,T3,T4) \
+    FCALLSCFUN4(VOID,CN,UN,LN,T1,T2,T3,T4)
+#define FCALLSCSUB5( CN,UN,LN,T1,T2,T3,T4,T5) \
+    FCALLSCFUN5(VOID,CN,UN,LN,T1,T2,T3,T4,T5)
+#define FCALLSCSUB6( CN,UN,LN,T1,T2,T3,T4,T5,T6) \
+    FCALLSCFUN6(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6)       
+#define FCALLSCSUB7( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+    FCALLSCFUN7(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7)
+#define FCALLSCSUB8( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+    FCALLSCFUN8(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8)
+#define FCALLSCSUB9( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+    FCALLSCFUN9(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9)
+#define FCALLSCSUB10(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+   FCALLSCFUN10(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA)
+#define FCALLSCSUB11(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+   FCALLSCFUN11(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB)
+#define FCALLSCSUB12(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+   FCALLSCFUN12(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC)
+#define FCALLSCSUB13(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+   FCALLSCFUN13(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD)
+#define FCALLSCSUB14(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+   FCALLSCFUN14(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define FCALLSCSUB15(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+   FCALLSCFUN15(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF)
+#define FCALLSCSUB16(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+   FCALLSCFUN16(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG)
+#define FCALLSCSUB17(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+   FCALLSCFUN17(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH)
+#define FCALLSCSUB18(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+   FCALLSCFUN18(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI)
+#define FCALLSCSUB19(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+   FCALLSCFUN19(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ)
+#define FCALLSCSUB20(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+   FCALLSCFUN20(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define FCALLSCSUB21(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \
+   FCALLSCFUN21(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL)
+#define FCALLSCSUB22(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \
+   FCALLSCFUN22(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM)
+#define FCALLSCSUB23(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \
+   FCALLSCFUN23(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN)
+#define FCALLSCSUB24(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \
+   FCALLSCFUN24(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO)
+#define FCALLSCSUB25(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \
+   FCALLSCFUN25(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP)
+#define FCALLSCSUB26(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \
+   FCALLSCFUN26(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ)
+#define FCALLSCSUB27(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+   FCALLSCFUN27(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+
+#define FCALLSCFUN1( T0,CN,UN,LN,T1) \
+        FCALLSCFUN5 (T0,CN,UN,LN,T1,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN2( T0,CN,UN,LN,T1,T2) \
+        FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,CF_0,CF_0,CF_0)
+#define FCALLSCFUN3( T0,CN,UN,LN,T1,T2,T3) \
+        FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,CF_0,CF_0)
+#define FCALLSCFUN4( T0,CN,UN,LN,T1,T2,T3,T4) \
+        FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,T4,CF_0)
+#define FCALLSCFUN5( T0,CN,UN,LN,T1,T2,T3,T4,T5) \
+        FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN6( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6) \
+        FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN7( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+        FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0)
+#define FCALLSCFUN8( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+        FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0)
+#define FCALLSCFUN9( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+        FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0)
+#define FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+        FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN11(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+        FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define FCALLSCFUN12(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+        FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define FCALLSCFUN13(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+        FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+
+#define FCALLSCFUN15(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+        FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN16(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+        FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN17(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+        FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0)
+#define FCALLSCFUN18(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+        FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0)
+#define FCALLSCFUN19(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+        FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0)
+#define FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN21(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN22(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN23(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN24(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0)
+#define FCALLSCFUN25(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0)
+#define FCALLSCFUN26(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0)
+
+
+#ifndef __CF__KnR
+#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf2(T0))   \
+        {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)}
+
+#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    \
+                                 CFextern _(T0,_cfF)(UN,LN)                    \
+ CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) )  \
+ {                 CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    \
+  _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0)      CN(    TCF(LN,T1,1,0)  TCF(LN,T2,2,1) \
+    TCF(LN,T3,3,1)  TCF(LN,T4,4,1) TCF(LN,T5,5,1)  TCF(LN,T6,6,1)  TCF(LN,T7,7,1) \
+    TCF(LN,T8,8,1)  TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+    TCF(LN,TD,13,1) TCF(LN,TE,14,1) );                          _Icf(0,K,T0,0,0) \
+                   CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)  _(T0,_cfI) }
+
+#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)   \
+                                 CFextern _(T0,_cfF)(UN,LN)                    \
+ CFARGT27(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) ) \
+ {                 CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)   \
+  _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0)      CN(     TCF(LN,T1,1,0)  TCF(LN,T2,2,1)  \
+    TCF(LN,T3,3,1)  TCF(LN,T4,4,1)  TCF(LN,T5,5,1)  TCF(LN,T6,6,1)  TCF(LN,T7,7,1)  \
+    TCF(LN,T8,8,1)  TCF(LN,T9,9,1)  TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+    TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \
+    TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \
+    TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \
+                   CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)  _(T0,_cfI) }
+
+#else
+#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf3(T0)) _Icf(0,FF,T0,0,0)\
+        {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)}
+
+#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    \
+                                 CFextern _(T0,_cfF)(UN,LN)                    \
+ CFARGT14(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)) _Icf(0,FF,T0,0,0) \
+       CFARGT14FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE);   \
+ {                 CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    \
+  _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0)      CN(  TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
+    TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
+    TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+    TCF(LN,TD,13,1) TCF(LN,TE,14,1) );                          _Icf(0,K,T0,0,0) \
+                   CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)  _(T0,_cfI)}
+
+#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)  \
+                                 CFextern _(T0,_cfF)(UN,LN)                    \
+ CFARGT27(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)) _Icf(0,FF,T0,0,0) \
+       CFARGT27FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR); \
+ {                 CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)  \
+  _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0)      CN(     TCF(LN,T1,1,0)  TCF(LN,T2,2,1)  \
+    TCF(LN,T3,3,1)  TCF(LN,T4,4,1)  TCF(LN,T5,5,1)  TCF(LN,T6,6,1)  TCF(LN,T7,7,1)  \
+    TCF(LN,T8,8,1)  TCF(LN,T9,9,1)  TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+    TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \
+    TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \
+    TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \
+                   CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)  _(T0,_cfI)}
+
+#endif
+
+
+#endif	 /* __CFORTRAN_LOADED */

EnKF-MPI-TOPAZ/distribute.F90

@@ -0,0 +1,103 @@
+module distribute
+
+#if defined(QMPI)
+  use qmpi
+#else
+  use qmpi_fake
+#endif
+
+  !
+  ! public stuff
+  !
+  integer, public :: my_number_of_iterations, my_first_iteration, my_last_iteration
+  integer, dimension(:), allocatable, public :: number_of_iterations, first_iteration, last_iteration
+  integer, dimension(:), allocatable, public :: randommap
+
+contains
+
+  subroutine distribute_iterations(nz)
+    implicit none
+
+    integer, intent(in) :: nz
+
+    integer :: i, j
+    real(8) :: num_procs_real, mean_iterations
+
+    if (.not. allocated(number_of_iterations)) then
+       allocate(number_of_iterations(qmpi_num_proc))
+    end if
+    if (.not. allocated(first_iteration)) then
+       allocate(first_iteration(qmpi_num_proc))
+    end if
+    if (.not. allocated(last_iteration)) then
+       allocate(last_iteration(qmpi_num_proc))
+    end if
+
+    if (master) then
+       print *, 'Distribution of iterations:'
+    end if
+
+    num_procs_real = qmpi_num_proc
+    mean_iterations = nz / num_procs_real
+
+    j = -1
+    if (int(mean_iterations) .eq. mean_iterations) then
+       my_number_of_iterations = nz/qmpi_num_proc
+       if (master) then
+          number_of_iterations(:) = nz / qmpi_num_proc
+          print *, 'All procs get ', number_of_iterations(1), 'iterations'
+       endif
+       j = qmpi_num_proc
+    else
+       do i = 1, qmpi_num_proc
+          if (i * floor(mean_iterations) +&
+               (qmpi_num_proc-i) * ceiling(mean_iterations) .eq. nz) then
+             j = i
+             exit
+          endif
+       end do
+
+       if (qmpi_proc_num + 1 .le. j) then
+          my_number_of_iterations = floor(mean_iterations)
+       else
+          my_number_of_iterations = ceiling(mean_iterations)
+       endif
+
+       if (master) then
+          number_of_iterations(1:j) = floor(mean_iterations)
+          number_of_iterations(j+1:qmpi_num_proc) = ceiling(mean_iterations)
+          if ((j * floor(mean_iterations) +&
+               (qmpi_num_proc - j) * ceiling(mean_iterations)) .ne. nz) then
+             print *, 'ERROR in distribute_iteration()'
+             stop
+          endif
+          if (nz .lt. qmpi_num_proc) then
+             print *, 'Number of cells in z-direction than number of processors'
+             stop
+          endif
+       endif
+    endif
+
+    if (master) then
+       first_iteration(1) = 1; 
+       last_iteration(1) = number_of_iterations(1)
+       do i = 2, qmpi_num_proc
+          first_iteration(i) = last_iteration(i - 1) + 1 
+          last_iteration(i) = first_iteration(i) + number_of_iterations(i)-1
+       end do
+    endif
+
+    if (qmpi_proc_num + 1 .le. j) then
+       my_first_iteration = qmpi_proc_num*my_number_of_iterations + 1
+    else
+       my_first_iteration = j * (my_number_of_iterations - 1) +&
+            (qmpi_proc_num - j) * my_number_of_iterations + 1
+    endif
+    my_last_iteration = my_first_iteration + my_number_of_iterations - 1
+
+    print *, 'I am', qmpi_proc_num, ', my_first_ind =', my_first_iteration,&
+         ', my_last_ind =', my_last_iteration
+  end subroutine distribute_iterations
+
+end module distribute
+

EnKF-MPI-TOPAZ/list.txt

@@ -0,0 +1,23 @@
+en     1 75  2
+hdivb  1 75  2
+hdivn  1 75  2
+rhop   1 75  2
+rotb   1 75  2
+rotn   1 75  2
+sb     1 75  2
+sn     1 75  2
+sshb   0  0  2
+ssh_m  0  0  2
+sshn   0  0  2
+sss_m  0  0  2
+sst_m  0  0  2
+ssu_m  0  0  2
+ssv_m  0  0  2 
+tb     1 75  2
+tn     1 75  2
+ub     1 75  2
+un     1 75  2
+utau_b 0  0  2
+vb     1 75  2
+vn     1 75  2
+vtau_b 0  0  2

EnKF-MPI-TOPAZ/m_Generate_element_Si.F90

@@ -0,0 +1,420 @@
+module m_Generate_element_Si
+  implicit none
+
+  public Generate_element_Si
+  public get_S
+
+  integer, parameter, private :: NONE = 0
+  integer, parameter, private :: TEMPERATURE = 1
+  integer, parameter, private :: SALINITY = 2
+
+  real, parameter, private :: TEM_MIN = -2.5
+  real, parameter, private :: TEM_MAX = 35.0
+  real, parameter, private :: SAL_MIN = 5.0
+  real, parameter, private :: SAL_MAX = 41.0
+
+  logical, parameter, private :: VERT_INTERP_GRID = .true.
+
+contains
+
+  subroutine Generate_element_Si(S, obstype, fld, depths, nx, ny, nz, t)
+    use mod_measurement
+    use m_obs
+    implicit none
+
+    real, dimension(nobs), intent(inout) :: S ! input/output vector
+    character(len=5), intent(in) :: obstype ! the model fld type in "fld"
+    integer, intent(in) :: nx,ny,nz ! grid size
+    real, intent(in) :: fld   (nx,ny) ! field to be placed in Si
+    real, intent(in) :: depths(nx,ny) ! depth mask -- needed for support 
+    integer, intent(in), optional :: t !time of fld
+
+    integer :: iobs
+    integer :: i, j, ip1, jp1
+    integer :: ix, jy, imin, imax, jmin, jmax, cnt
+
+    logical :: isprofile
+    real :: depth
+    integer :: ns
+
+    real, parameter :: undef = 999.9 ! land points have value huge()
+
+    ! TEM, GTEM, SAL and GSAL come from profiles
+    isprofile = (trim(obstype) .eq. 'SAL' .or.&
+         trim(obstype) .eq. 'GSAL' .or.&
+         trim(obstype) .eq. 'TEM' .or.&
+         trim(obstype) .eq. 'GTEM')
+
+    do iobs = 1, nobs
+       if (trim(obstype) == obs(iobs) % id) then
+          if (trim(obstype) .ne. 'TSLA' .or. obs(iobs) % date == t) then
+             ! Get model gridcell
+             i = obs(iobs) % ipiv
+             j = obs(iobs) % jpiv
+             ip1 = min(i + 1, nx)
+             jp1 = min(j + 1, ny)
+             
+             depth = obs(iobs) % depth
+             
+             !TODO: 1. check consistency for ns = 1 vs ns = 0
+             !      2. check consistency of running from -ns to +ns (this can
+             !         lead perhaps for averaginf over -1 0 1 = 3 x 3 instead
+             !         of 2 x 2 grid cells if ns = 1
+             if (depth .lt. 10.0 .and. .not. isprofile) then ! satellite data
+                ns = obs(iobs) % ns
+                if(ns .lt. 2) then ! point data : zero support
+                   S(iobs) = fld(i, j) * obs(iobs) % a1 &
+                        + fld(ip1, j) * obs(iobs) % a2 &
+                        + fld(ip1, jp1) * obs(iobs) % a3 &
+                        + fld(i, jp1) * obs(iobs) % a4
+                else ! data support assumed a square of 2ns * 2ns grid cells
+                   imin = max( 1, i - ns)
+                   imax = min(nx, i + ns)
+                   jmin = max( 1, j - ns)
+                   jmax = min(ny, j + ns)
+                   cnt = 0
+                   S(iobs) = 0.0
+                   do jy = jmin, jmax
+                      do ix = imin, imax
+                      ! Removes data on land, absolute values larger than 1000 and NaNs
+                         if (depths(ix, jy) > 1.0 .and. abs(fld(ix, jy)) < 10.0d3 .and. fld(ix, jy) + 1.0d0 /= fld(ix, jy)) then 
+                            S(iobs) = S(iobs) + fld(ix, jy)
+                            cnt = cnt + 1
+                         endif
+                      enddo
+                   enddo
+                   
+                   if (cnt == 0) then
+                      print *, ' observation on land ', i, j, obs(iobs) % d
+                      stop 'm_Generate_element_Sij: report bug to LB (laurentb@nersc.no)'
+                   end if
+                   S(iobs) = S(iobs) / real(cnt)
+                endif
+
+             elseif(isprofile) then      ! in-situ data (in depth)
+                print *,'(m_Generate_element_Si does not handle profiles yet)'
+                stop '(m_Generate_element_Si)'
+             else
+                stop 'Generate_element_Sij: not a profile but depth is deeper than 10m'
+             endif
+          end if ! obs and model are at similar time
+       end if ! (trim(obstype) == obs(iobs) % id) then
+    end do
+  end subroutine Generate_element_Si
+
+
+  ! Get S = HA for in-situ data. Linearly interpolate for obs positioned
+  ! between the layer centres; otherwise use the layer value for the obs above
+  ! the middle of the first layer or below the middle of the last layer.
+  !
+  ! Note - this procedure parses through all obs for each ensemble member
+  ! to work out profiles. This indeed invlolves some redundancy because
+  ! this work could be done only once. However, the penalty (I think) is
+  ! quite small compared to the time required for reading the fields from
+  ! files and does not worth modifying (and complicating) the code.
+  !
+  subroutine get_S(S, obstag, nobs, obs, iens)
+    use mod_measurement
+    use m_insitu
+    use m_get_mod_fld
+    use m_io_mod_fld ! CKB, FM
+    !use m_parse_blkdat
+    use m_get_mod_xyz ! was: m_parse_blkdat
+    use m_parameters
+    implicit none
+
+    real, dimension(nobs), intent(inout) :: S
+    character(*), intent(in) :: obstag
+    integer, intent(in) :: nobs
+    type(measurement), dimension(nobs) :: obs
+    integer, intent(in) :: iens
+
+    real, parameter :: ONEMETER = 9806.0
+
+    ! obs stuff
+    !
+    integer :: p, o
+    integer, allocatable, dimension(:) :: ipiv, jpiv
+    real, allocatable, dimension(:) :: a1, a2, a3, a4
+
+    ! grid stuff
+    !
+    integer :: k
+    integer :: ni, nj, nk
+    real :: rdummy
+
+    ! vertical stuff
+    !
+    real, allocatable, dimension(:) :: zgrid, zcentre, zgrid_prev, zcentre_prev
+    real, allocatable, dimension(:) :: v, v_prev
+    
+    ! fields & I/O stuff
+    !
+    real, allocatable, dimension(:, :) :: dz2d, v2d, sstbias, mld, offset, z
+    integer :: tlevel
+    character(8) :: fieldtag
+    character(3) :: cmem
+    character(80) :: fname
+    real, dimension(2, 2) :: dz_cell, v_cell
+    real :: dz, depth, z0, z1, z01, delta
+    integer :: field
+
+    field = NONE
+
+    if (nobs == 0) then
+       return
+    end if
+
+    if (master .and. iens == 1) then
+       if (VERT_INTERP_GRID) then
+          print *, trim(obstag), ': vertical interpolation in grid space'
+       else
+          print *, trim(obstag), ': vertical interpolation in physical space'
+       end if
+    end if
+
+    !
+    ! 1. Identify profiles presented in "obs"
+    !
+
+    ! note that profiles are being used in the vertical superobing by each 
+    ! ensemble member...
+    !
+    call insitu_setprofiles(obstag, nobs, obs)
+
+    allocate(ipiv(nprof))
+    allocate(jpiv(nprof))
+    allocate(a1(nprof))
+    allocate(a2(nprof))
+    allocate(a3(nprof))
+    allocate(a4(nprof))
+    allocate(zgrid(nprof))
+    allocate(zgrid_prev(nprof))
+    allocate(zcentre(nprof))
+    allocate(zcentre_prev(nprof))
+    allocate(v(nprof))
+    allocate(v_prev(nprof))
+
+    ipiv = obs(pstart(1 : nprof)) % ipiv
+    jpiv = obs(pstart(1 : nprof)) % jpiv
+    a1 = obs(pstart(1 : nprof)) % a1
+    a2 = obs(pstart(1 : nprof)) % a2
+    a3 = obs(pstart(1 : nprof)) % a3
+    a4 = obs(pstart(1 : nprof)) % a4
+
+    !
+    ! 2. Map the observations for this ensemble member proceeding by layers
+    !    to reduce I/O:
+    !
+    !    -cycle through layers
+    !       -find the middle of this layer
+    !       -cycle through profiles
+    !          -for each obs between the middle of the prev layer and the
+    !           middle of this layer
+    !             -interpolate the field value
+    !             -write to S
+    !
+
+    ! get grid dimensions
+    !
+    !call parse_blkdat('idm   ','integer', rdummy, ni)
+    !call parse_blkdat('jdm   ','integer', rdummy, nj)
+    !call parse_blkdat('kdm   ','integer', rdummy, nk)
+    call get_mod_xyz(ni, nj, nk) ! [CKB,FM] Changed from using m_parse_blkdat
+
+    allocate(v2d(ni, nj))
+    allocate(dz2d(ni, nj))
+
+    if (trim(obstag) == 'SAL' .or. trim(obstag) == 'GSAL') then
+       fieldtag = 'saln    '
+       field = SALINITY
+    elseif (trim(obstag) == 'TEM' .or. trim(obstag) == 'GTEM') then
+       fieldtag = 'temp    '
+       field = TEMPERATURE
+    else
+       if (master) then
+          print *, 'ERROR: get_S(): unknown observatioon tag "', trim(obstag), '"'
+       end if
+       stop
+    end if
+    write(cmem, '(i3.3)') iens
+    fname = 'forecast'//cmem
+
+    if (field == TEMPERATURE .and. prm_prmestexists('sstb')) then
+       allocate(sstbias(ni, nj))
+       allocate(mld(ni, nj))
+       allocate(offset(ni, nj))
+       allocate(z(ni, nj))
+       z = 0.0d0
+
+       tlevel = 1
+       call get_mod_fld_new(trim(fname), sstbias, iens, 'sstb ', 0, tlevel, ni, nj)
+       if (tlevel == -1) then
+          if (master) then
+             print *, 'ERROR: get_mod_fld_new(): failed for "sstb"'
+          end if
+          stop
+       end if
+       call get_mod_fld_new(trim(fname), mld, iens, 'dpmixl  ', 0, tlevel, ni, nj)
+       if (tlevel == -1) then
+          if (master) then
+             print *, 'ERROR: get_mod_fld_new(): failed for "dpmixl"'
+          end if
+          stop
+       end if
+     end if
+
+    ! cycle through layers
+    !
+    tlevel = 1
+    do k = 1, nk + 1
+
+       if (k == 1) then
+          zgrid_prev = 0.0
+          zcentre_prev = 0.0
+       end if
+
+       if (k <= nk) then
+
+          ! read the depth and the requested field at this layer
+          !
+          call get_mod_fld_new(trim(fname), dz2d, iens, 'dp      ', k, tlevel, ni, nj)
+          if (tlevel == -1) then
+             if (master) then
+                print *, 'ERROR: get_mod_fld_new(): failed for "dp"'
+             end if
+             stop
+          end if
+          call get_mod_fld_new(trim(fname), v2d, iens, fieldtag, k, tlevel, ni, nj)
+          if (tlevel == -1) then
+             if (master) then
+                print *, 'ERROR: get_mod_fld_new(): failed for "', fieldtag, '"'
+             end if
+             stop
+          end if
+       end if
+
+       ! calculate correction from SST bias at this depth
+       !
+       if (field == TEMPERATURE .and. prm_prmestexists('sstb')) then
+          offset = 0.0d0
+          z = z + dz2d / 2.0 ! at the middle of the layer
+          where (mld > 0.0d0 .and. mld < 1.0d8) ! < 10000 m
+             offset = sstbias * exp(-(z / mld) ** 2)
+          end where
+          v2d = v2d - offset
+          z = z + dz2d / 2.0
+       end if
+
+       ! cycle through profiles
+       !
+       do p = 1, nprof
+          if (k <= nk) then
+             dz_cell(:, :) = dz2d(ipiv(p) : ipiv(p) + 1, jpiv(p) : jpiv(p) + 1)
+             dz = dz_cell(1, 1) * a1(p) + dz_cell(2, 1) * a2(p)&
+                  + dz_cell(1, 2) * a3(p) + dz_cell(2, 2) * a4(p)
+             dz = dz / ONEMETER
+             zgrid(p) = zgrid_prev(p) + dz
+             zcentre(p) = (zgrid_prev(p) + zgrid(p)) / 2.0
+             v_cell(:, :) = v2d(ipiv(p) : ipiv(p) + 1, jpiv(p) : jpiv(p) + 1)
+             v(p) = v_cell(1, 1) * a1(p) + v_cell(2, 1) * a2(p)&
+                  + v_cell(1, 2) * a3(p) + v_cell(2, 2) * a4(p)
+          else
+             ! for the lower half of the last layer -- just use the layer value
+             ! (note that there was no reading in this case, so that 
+             ! v = v_prev)
+             zcentre(p) = zgrid(p)
+          end if
+
+          if (k == 1) then
+             v_prev(p) = v(p)
+          end if
+
+          ! cycle through the obs, pick the ones in between the middle of the
+          ! previous layer and the middle of this layer, interpolate the
+          ! ensemble field to their locations, and save the results in S
+          !
+          z0 = zcentre_prev(p)
+          z1 = zcentre(p)
+          z01 = zgrid_prev(p)
+          if (z1 == z0) then
+             cycle
+          end if
+          do while (pstart(p) <= pend(p))
+             o = pstart(p)
+             depth = obs(o) % depth
+
+             ! check that this obs is within the current layer
+             !
+             if (depth > z1 .and. k <= nk) then
+                exit ! next profile
+             elseif (depth >= z0 .and. depth <= z1) then
+
+                if (.not. VERT_INTERP_GRID) then
+                   ! interpolate linearly in physical space
+                   !
+                   S(o) = (z1 - depth) / (z1 - z0) * v_prev(p) +&
+                        (depth - z0) / (z1 - z0) * v(p)
+                else
+                   ! interpolate linearly in the grid space
+                   !
+                   if (depth < z01) then
+                      delta = 0.5d0 * (depth - z0) / (z01 - z0)
+                   else
+                      delta = 0.5d0 + 0.5d0 * (depth - z01) / (z1 - z01)
+                   end if
+                   S(o) = (1.0d0 - delta) * v_prev(p) + delta * v(p)
+                end if
+
+                ! Here we check the range of interpolated ensemble values;
+                ! the range of observed values is checked in insitu_QC().
+                !
+                if (field == SALINITY) then
+                   if ((S(o) < SAL_MIN .or. S(o) > SAL_MAX) .and. master) then
+                      print *, 'WARNING: get_S(): suspicious value (SAL): ',&
+                           'iens =', iens, ', obs =', o, ', profile = ', p,&
+                           'depth =', depth, ', S =', S(o)
+                   end if
+                else if (field == TEMPERATURE) then
+                   if ((S(o) < TEM_MIN .or. S(o) > TEM_MAX) .and. master) then
+                      print *, 'WARNING: get_S(): suspicious value (TEM): ',&
+                           'iens =', iens, ', obs =', o, ', profile = ', p,&
+                           'depth =', depth, ', S =', S(o)
+                   end if
+                end if
+             else ! k == nk + 1
+                S(o) = v(p)
+             end if
+                ! go to the next obs
+                !
+                pstart(p) = pstart(p) + 1
+          end do ! o
+       end do ! p
+       zgrid_prev = zgrid
+       zcentre_prev = zcentre
+       v_prev = v
+    end do ! k
+
+    deallocate(dz2d)
+    deallocate(v2d)
+    deallocate(v_prev)
+    deallocate(v)
+    deallocate(zcentre_prev)
+    deallocate(zcentre)
+    deallocate(zgrid_prev)
+    deallocate(zgrid)
+    deallocate(a4)
+    deallocate(a3)
+    deallocate(a2)
+    deallocate(a1)
+    deallocate(jpiv)
+    deallocate(ipiv)
+    if (allocated(sstbias)) then
+       deallocate(sstbias)
+       deallocate(mld)
+       deallocate(offset)
+       deallocate(z)
+    end if
+  end subroutine get_S
+
+end module m_Generate_element_Si

EnKF-MPI-TOPAZ/m_bilincoeff.F90

@@ -0,0 +1,107 @@
+module m_bilincoeff
+  use m_oldtonew
+  implicit none
+
+contains
+
+  ! This subroutine uses bilinear interpolation to interpolate the field
+  ! computed by the model (MICOM) to the position defined by lon, lat
+  ! The output is the interpolation coeffisients a[1-4]
+  ! NB  NO locations on land.
+  !
+  subroutine bilincoeff(glon, glat, nx, ny, lon, lat, ipiv, jpiv, a1, a2, a3, a4)
+    real, intent(in) :: glon(nx, ny), glat(nx, ny)
+    integer, intent(in) :: nx ,ny
+    real, intent(in) :: lon, lat
+    integer, intent(in) :: ipiv, jpiv
+    real, intent(out) :: a1, a2, a3, a4
+
+    real :: t, u
+    real :: lat1, lon1, lat2, lon2, latn, lonn
+
+
+    call oldtonew(glat(ipiv, jpiv), glon(ipiv, jpiv), lat1, lon1)
+    call oldtonew(glat(ipiv + 1, jpiv + 1), glon(ipiv + 1, jpiv + 1), lat2, lon2)
+    call oldtonew(lat, lon, latn, lonn)
+
+    t = (lonn - lon1) / (lon2 - lon1)
+    u = (latn - lat1) / (lat2 - lat1)
+
+    if (t < -0.1 .or. t > 1.1 .or. u < -0.1 .or. u > 1.1) then
+       print *, 'ERROR: bilincoeff(): t, u = ', t, u, 'for lon, lat =', lon, lat
+       stop
+    end if
+
+    a1 = (1.0 - t) * (1.0 - u)
+    a2 = t * (1.0 - u)
+    a3 = t * u
+    a4 = (1.0 - t) * u
+  end subroutine bilincoeff
+
+  subroutine bilincoeff1(glon, glat, nx, ny, lon, lat, ipiv, jpiv, a1, a2, a3, a4)
+    real, intent(in) :: glon(nx, ny), glat(nx, ny)
+    integer, intent(in) :: nx ,ny
+    real, intent(in) :: lon, lat
+    integer, intent(in) :: ipiv, jpiv
+    real, intent(out) :: a1, a2, a3, a4
+
+    real :: xx(4), yy(4)
+    real :: t, u
+
+    xx(1) = glon(ipiv, jpiv)
+    xx(2) = glon(ipiv + 1, jpiv)
+    xx(3) = glon(ipiv + 1, jpiv + 1)
+    xx(4) = glon(ipiv, jpiv + 1)
+    yy(1) = glat(ipiv, jpiv)
+    yy(2) = glat(ipiv + 1, jpiv)
+    yy(3) = glat(ipiv + 1, jpiv + 1)
+    yy(4) = glat(ipiv, jpiv + 1)
+    call xy2fij(lon, lat, xx, yy, t, u)
+    if (t < 0 .or. t > 1 .or. u < 0 .or. u > 1) then
+       print *, 'ERROR: bilincoeff(): t, u = ', t, u, 'for lon, lat =', lon, lat
+       !       stop
+    end if
+
+    a1 = (1.0 - t) * (1.0 - u)
+    a2 = t * (1.0 - u)
+    a3 = t * u
+    a4 = (1.0 - t) * u
+  end subroutine bilincoeff1
+
+  subroutine xy2fij(x, y, xx, yy, fi, fj)
+    real, intent(in) :: x, y
+    real, intent(in) :: xx(4), yy(4)
+    real, intent(out) :: fi, fj
+
+    real :: a, b, c, d, e, f, g, h
+    real :: aa, bb, cc
+    real :: d1, d2
+
+    a = xx(1) - xx(2) - xx(4) + xx(3)
+    b = xx(2) - xx(1)
+    c = xx(4) - xx(1)
+    d = xx(1)
+    e = yy(1) - yy(2) - yy(4) + yy(3)
+    f = yy(2) - yy(1)
+    g = yy(4) - yy(1)
+    h = yy(1)
+
+    aa = a * f - b * e;
+    bb = e * x - a * y + a * h - d * e + c * f - b * g;
+    cc = g * x - c * y + c * h - d * g;
+
+    if (abs(aa) < 1d-5) then
+       fi = -cc / bb * (1.0d0 + aa * cc / bb / bb);
+    else
+       fi = (-bb - sqrt(bb * bb - 4.0d0 * aa * cc)) / (2.0d0 * aa);
+    end if
+    d1 = a * fi + c
+    d2 = e * fi + g
+    if (abs(d2) > abs(d1)) then
+       fj = (y - f * fi - h) / d2
+    else
+       fj = (x - b * fi - d) / d1
+    end if
+  end subroutine xy2fij
+
+end module m_bilincoeff

EnKF-MPI-TOPAZ/m_confmap.F90

@@ -0,0 +1,121 @@
+module m_confmap
+  implicit none
+
+  logical :: confmap_initialised = .false.
+
+  real :: pi_1
+  real :: pi_2
+  real :: deg
+  real :: rad
+  real :: theta_a
+  real :: phi_a
+  real :: theta_b
+  real :: phi_b
+  real :: di
+  real :: dj
+  complex :: imagone
+  complex :: ac
+  complex :: bc
+  complex :: cmna
+  complex :: cmnb
+  real :: mu_s
+  real :: psi_s
+  real :: epsil
+  logical :: mercator
+
+  real :: lat_a, lon_a
+  real :: lat_b, lon_b
+  real :: wlim, elim
+  real :: slim, nlim
+  real :: mercfac
+  integer :: ires, jres
+
+contains
+
+  ! This routine initializes constants used in the conformal mapping
+  ! and must be called before the routines 'oldtonew' and 'newtoold'
+  ! are called. The arguments of this routine are the locations of
+  ! the two poles in the old coordiante system.
+  !
+  subroutine confmap_init(nx, ny)
+    integer, intent(in) :: nx, ny
+
+    real :: cx, cy, cz, theta_c, phi_c
+    complex :: c, w
+    logical :: ass, lold
+    
+    ! Read info file
+    open(unit = 10, file = 'grid.info', form = 'formatted')
+    read(10, *) lat_a, lon_a
+    read(10, *) lat_b,lon_b
+    read(10, *) wlim, elim, ires
+    read(10, *) slim, nlim, jres
+    read(10, *) ass
+    read(10, *) ass
+    read(10, *) ass
+    read(10, *) mercator
+    read(10, *) mercfac, lold
+    close(10)
+    if (ires /= nx .and. jres /= ny) then
+       print *, 'initconfmap: WARNING -- the dimensions in grid.info are not'
+       print *, 'initconfmap: WARNING -- consistent with nx and ny'
+       print *, 'initconfmap: WARNING -- IGNORE IF RUNNING CURVIINT'
+       stop '(initconfmap)'
+    endif
+
+    ! some constants
+    !
+    pi_1 = 3.14159265358979323846
+    pi_2 = 0.5 * pi_1
+    deg = 180.0 / pi_1
+    rad = 1.0 / deg
+    epsil = 1.0d-9
+
+    di = (elim - wlim) / real(ires - 1)   ! delta lon'
+    dj = (nlim - slim) / real(jres - 1)   ! delta lat' for spherical grid
+
+    if (mercator) then
+       dj = di
+       if (lold) then
+          print *, 'initconfmap: lold'
+          slim = -mercfac * jres * dj
+       else
+          print *, 'initconfmap: not lold'
+          slim = mercfac
+       endif
+    endif
+
+    ! transform to spherical coordinates
+    !
+    theta_a = lon_a * rad
+    phi_a = pi_2 - lat_a * rad
+    theta_b = lon_b * rad
+    phi_b = pi_2 - lat_b * rad
+
+    ! find the angles of a vector pointing at a point located exactly
+    ! between the poles
+    !
+    cx = cos(theta_a) * sin(phi_a) + cos(theta_b) * sin(phi_b)
+    cy = sin(theta_a) * sin(phi_a) + sin(theta_b) * sin(phi_b)
+    cz = cos(phi_a) + cos(phi_b)
+
+    theta_c = atan2(cy, cx)
+    phi_c = pi_2 - atan2(cz, sqrt(cx * cx + cy * cy))
+
+    ! initialize constants used in the conformal mapping
+    !
+    imagone = (0.0, 1.0)
+    ac = tan(0.5 * phi_a) * exp(imagone * theta_a)
+    bc = tan(0.5 * phi_b) * exp(imagone * theta_b)
+    c = tan(0.5 * phi_c) * exp(imagone * theta_c)
+    cmna = c - ac
+    cmnb = c - bc
+
+    w = cmnb / cmna
+    mu_s = atan2(aimag(w), real(w))
+    psi_s = 2.0 * atan(abs(w))
+
+    confmap_initialised = .true.
+  end subroutine confmap_init
+
+end module m_confmap

EnKF-MPI-TOPAZ/m_get_mod_fld.F90

@@ -0,0 +1,145 @@
+module m_get_mod_fld
+! KAL -- This routine reads one of the fields from the model, specified
+! KAL -- by name, vertical level and time level 
+! KAL -- This routine is really only effective for the new restart files.
+
+contains
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+subroutine get_mod_fld(fld,j,cfld,vlevel,tlevel,nx,ny)
+#if defined (QMPI)
+   use qmpi
+#else
+   use qmpi_fake
+#endif
+   implicit none
+   integer,      intent(in)            :: nx,ny  ! Grid dimension
+   integer,      intent(in)            :: j      ! Ensemble member to read
+   real, dimension(nx,ny), intent(out) :: fld    ! output fld
+   character(len=*), intent(in)        :: cfld   ! name of fld
+   integer, intent(in)                 :: tlevel ! time level
+   integer, intent(in)                 :: vlevel ! vertical level
+
+   integer reclICE
+   real*8, dimension(nx,ny) :: ficem,hicem,hsnwm,ticem,tsrfm
+
+   logical ex
+
+   character(len=*),parameter :: icefile='forecastICE.uf'
+
+   ! KAL -- shortcut -- the analysis is for observation icec -- this little "if" 
+   ! means the  analysis will only work for ice. Add a check though
+   if ((trim(cfld)/='icec' .and. trim(cfld)/='hice')  .or. vlevel/=0 .or. tlevel/=1)then
+      if (master) print *,'get_mod_fld only works for icec for now'
+      call stop_mpi()
+   end if
+
+!###################################################################
+!####################### READ  ICE   MODEL #########################
+!###################################################################
+#if defined (ICE)
+#warning "COMPILING WITH ICE"
+   inquire(exist=ex,file=icefile)
+   if (.not.ex) then
+      if (master) then
+         print *,icefile//' does not exist!'
+         print *,'(get_mod_fld)'
+      end if
+      call stop_mpi()
+   end if
+   inquire(iolength=reclICE)ficem,hicem,hsnwm,ticem,tsrfm  !,iceU,iceV
+   open(10,file=icefile,form='unformatted',access='direct',recl=reclICE,action='read')
+      read(10,rec=j)ficem,hicem,hsnwm,ticem,tsrfm !,iceU,iceV
+      if (trim(cfld)=='icec') fld = ficem
+      if (trim(cfld)=='hice') fld = hicem
+   close(10)
+#else
+#warning "COMPILING WITHOUT ICE"
+#endif
+
+
+  return
+end subroutine get_mod_fld
+
+
+
+! KAL - This is for the new file type
+subroutine get_mod_fld_new(memfile,fld,iens,cfld,vlevel,tlevel,nx,ny)
+   use mod_raw_io
+#if defined (QMPI)
+   use qmpi, only : qmpi_proc_num, master
+#else
+   use qmpi_fake
+#endif
+   implicit none
+   integer,      intent(in)            :: nx,ny  ! Grid dimension
+   integer,      intent(in)            :: iens   ! Ensemble member to read
+   real, dimension(nx,ny), intent(out) :: fld    ! output fld
+   character(len=*), intent(in)        :: memfile! base name of input files
+   character(len=*), intent(in)        :: cfld   ! name of fld
+   integer, intent(in)                 :: tlevel ! time level
+   integer, intent(in)                 :: vlevel ! vertical level
+
+   real*8, dimension(nx,ny) :: readfldr8
+   real*4, dimension(nx,ny) :: readfldr4
+   real*4:: amin, amax,spval
+   real :: bmin, bmax
+   integer :: indx
+
+
+   ! Dette fordi is-variablane forelobig er paa gammalt format.
+   if (trim(cfld) /= 'icec' .and. trim(cfld) /= 'hice') then
+
+      ! KAL - 1) f kva index som skal lesast finn vi fraa .b fil (header)
+      call rst_index_from_header(trim(memfile)//'.b', & ! filnavn utan extension
+                                 cfld               , & ! felt som skal lesast fex saln,temp
+                                 vlevel,              & ! vertikalnivaa
+                                 tlevel,              & ! time level - kan vere 1 eller 2 - vi bruker 1 foreloepig
+                                 indx,                & ! indexen som maa lesas fra data fila
+                                 bmin,bmax,           & ! min/max - kan sjekkast mot det som er i datafila
+                                 .true. )
+
+      if (indx < 0) then
+         if (master) then
+            print *, 'ERROR: get_mod_fld_new(): ', trim(memfile), '.b: "',&
+                 trim(cfld), '" not found'
+         end if
+         stop
+      end if
+
+      ! KAL -- les datafelt vi fann fraa header fila (indx)
+      spval=0.
+      call READRAW(readfldr4          ,& ! Midlertidig felt som skal lesast
+                   amin, amax         ,& ! max/min fraa data (.a) fila 
+                   nx,ny              ,& ! dimensjonar
+                   .false.,spval      ,& ! dette brukast for  sette "no value" verdiar
+                   trim(memfile)//'.a',& ! fil som skal lesast fraa
+                   indx)                 ! index funne over
+
+     ! Sjekk p at vi har lest rett - samanlign max/min fr filene
+     if     (abs(amin-bmin).gt.abs(bmin)*1.e-4 .or. &
+             abs(bmax-amax).gt.abs(bmax)*1.e-4     ) then
+        print *,'Inconsistency between .a and .b files'
+        print *,'.a : ',amin,amax
+        print *,'.b : ',bmin,bmax
+        print *,cfld,vlevel,tlevel
+        print *,indx
+        print *,'node ',qmpi_proc_num
+        call exit(1)
+     end if
+     fld=readfldr4
+
+   else ! fld = fice, hice
+      ! Gammal rutine ja
+      call get_mod_fld(readfldr8,iens,cfld,0,1,nx,ny)
+      fld=readfldr8
+   end if
+
+
+end subroutine
+
+
+
+end module m_get_mod_fld
+
+

EnKF-MPI-TOPAZ/m_get_mod_grid.F90

@@ -0,0 +1,169 @@
+module m_get_mod_grid
+
+! The reading of depths is not needed for assimilation of sea-ice data
+! but left here for potential future use. And to retain the calling format.
+
+  use netcdf
+#if defined (QMPI)
+  use qmpi
+#else
+  use qmpi_fake
+#endif
+
+  private handle_err
+
+contains 
+  subroutine get_mod_grid(modlon,modlat,depths,mindx,meandx,nx,ny)
+
+  implicit none
+
+  ! In/out
+  integer,                intent(in)  :: nx,ny  ! 182, resp. 149
+  real, dimension(nx,ny), intent(out) :: modlon, modlat, depths
+  real,                   intent(out) :: mindx, meandx
+
+  ! NetCDF vars
+  integer ncid, varID, error, ncid_mask, ncid_zgr
+  character(len=80), parameter :: maskfile = 'mask.nc' !hc!
+  character(len=80), parameter :: meshfile_hgr = 'mesh_hgr.nc' !hc!
+  character(len=80), parameter :: meshfile_zgr = 'mesh_zgr.nc' !hc!
+    
+  logical ex
+
+  ! Variables for mindx   ! uncomment whatever is needed
+  real, allocatable, dimension(:,:) :: e1t, e2t!, e1u, e2u, e1v, e2v, e1f, e2f
+  real, allocatable, dimension(:,:) :: tmask!, umask, vmask, fmask
+
+
+  ! check the netCDF file exists
+  inquire(file=meshfile_hgr, exist=ex)
+  if (.not.ex) then
+     if (master) print *, '(get_mod_grid): file does not exist: '//trim(meshfile_hgr)
+     call stop_mpi()
+  end if
+
+  ! open the netCDF file
+  error = nf90_open(trim(maskfile),nf90_NoWrite,ncid_mask)
+  if (error.ne.nf90_noerr) call handle_err(error, "opening")
+  error = nf90_open(trim(meshfile_hgr),nf90_NoWrite,ncid)
+  if (error.ne.nf90_noerr) call handle_err(error, "opening")
+  error = nf90_open(trim(meshfile_zgr),nf90_NoWrite,ncid_zgr)
+  if (error.ne.nf90_noerr) call handle_err(error, "opening")
+
+  ! Longitude
+  ! Find VarID
+  error = nf90_inq_varid(ncid, 'nav_lon', varID)
+  if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID modlon")
+  ! Get values of variable
+  error = nf90_get_var(ncid, varID, modlon)
+  if (error.ne.nf90_noerr) call handle_err(error, "getting variable modlon")
+
+  ! Latitude
+  ! Find VarID
+  error = nf90_inq_varid(ncid, 'nav_lat', varID)
+  if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID modlat")
+  ! Get values of variable
+  error = nf90_get_var(ncid, varID, modlat)
+  if (error.ne.nf90_noerr) call handle_err(error, "getting variable modlat")
+
+  ! Depths:
+  ! Find VarID
+  error = nf90_inq_varid(ncid_zgr, 'gdept_0', varID)
+  if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID depths")
+  ! Get values of variable
+  error = nf90_get_var(ncid_zgr, varID, depths)
+  if (error.ne.nf90_noerr) call handle_err(error, "getting variable depths")
+
+  ! mindx: Smallest horizontal grid spacing. Requires some 'math'.
+  ! Load grid spacing and corresponding masks
+  allocate( e1t(nx,ny), e2t(nx,ny) )
+  !allocate( e1u(nx,ny), e2u(nx,ny) ) ! In case those variables are ...
+  !allocate( e1v(nx,ny), e2v(nx,ny) ) ! ... needed, feel free ...
+  !allocate( e1f(nx,ny), e2f(nx,ny) ) ! ... to uncomment.
+  allocate( tmask(nx,ny) ) ! umask(nx,ny), vmask(nx,ny), fmask(nx,ny) 
+
+  ! Get e1t, e1u, e1v, e1f, e2t, e2u, e2v, and e2f
+  error = nf90_inq_varid(ncid, 'e1t', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  error = nf90_get_var(ncid, varID, e1t) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+  error = nf90_inq_varid(ncid, 'e2t', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  error = nf90_get_var(ncid, varID, e2t) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+  !error = nf90_inq_varid(ncid, 'e1u', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  !error = nf90_get_var(ncid, varID, e1u) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+  !error = nf90_inq_varid(ncid, 'e2u', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  !error = nf90_get_var(ncid, varID, e2u) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+  !error = nf90_inq_varid(ncid, 'e1v', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  !error = nf90_get_var(ncid, varID, e1v) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+  !error = nf90_inq_varid(ncid, 'e2v', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  !error = nf90_get_var(ncid, varID, e2v) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+  !error = nf90_inq_varid(ncid, 'e1f', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  !error = nf90_get_var(ncid, varID, e1f) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+  !error = nf90_inq_varid(ncid, 'e2f', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  !error = nf90_get_var(ncid, varID, e2f) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+  ! Get tmask, umask, vmask, fmask   !!! only first level of 3d-nc-var fits into local var. It's all we need.
+  error = nf90_inq_varid(ncid_mask, 'tmask', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  error = nf90_get_var(ncid_mask, varID, tmask) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+  !error = nf90_inq_varid(ncid, 'umask', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  !error = nf90_get_var(ncid, varID, umask) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+  !error = nf90_inq_varid(ncid, 'vmask', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  !error = nf90_get_var(ncid, varID, vmask) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+  !error = nf90_inq_varid(ncid, 'fmask', varID) ; if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  !error = nf90_get_var(ncid, varID, fmask) ;     if (error.ne.nf90_noerr) call handle_err(error, "getting variable")
+
+  ! Smart use of min/maxval
+
+  ! Find absolute minimum
+  mindx = min(minval(e1t, tmask>0.5), minval(e2t, tmask>0.5))!, &
+            ! minval(e1u, umask>0.5), minval(e2u, umask>0.5), &
+            ! minval(e1v, vmask>0.5), minval(e2v, vmask>0.5), &
+            ! minval(e1f, fmask>0.5), minval(e2f, fmask>0.5) )
+  if (master) then
+     print *,'(get_mod_grid) MINIMUM grid size from mesh_mask : ', mindx
+  end if
+
+  ! Find mean horizontal distance
+  meandx = (sum(e1t,mask=tmask>0.5) + sum(e2t,mask=tmask>0.5) ) &
+       / count(tmask>0.5)
+  if (master) then
+     print *,'(get_mod_grid) MEAN grid size from mesh_mask: ', meandx
+  end if
+
+
+  ! Safety check ..        inherited from KAL
+  if (mindx<2000.) then
+     if (master) print *,'(get_mod_grid) min grid size lower than safety threshold - fix if you want'
+     call stop_mpi()
+  end if
+
+  ! Safety check .. This one is not that critical so the value is set high
+  if (mindx>500000.) then
+     if (master) print *,'(get_mod_grid) min grid size higher than safety threshold - fix if you want'
+     call stop_mpi()
+  end if
+
+  ! Close file
+  error = nf90_close(ncid)              ! close netCDF dataset
+  if (error.ne.nf90_noerr) call handle_err(error, "closing")
+  error = nf90_close(ncid_mask)              ! close netCDF dataset
+  if (error.ne.nf90_noerr) call handle_err(error, "closing")
+  error = nf90_close(ncid_zgr)              ! close netCDF dataset
+  if (error.ne.nf90_noerr) call handle_err(error, "closing")
+
+end subroutine  get_mod_grid
+
+subroutine handle_err(status, infomsg) 
+  integer,            intent ( in) :: status 
+  character(len = *), intent ( in), optional :: infomsg
+  if(status /= nf90_noerr) then
+     if (master) then
+        if (present(infomsg)) then
+           print *, 'Error while '//infomsg//' - '//trim(nf90_strerror(status)) 
+        else
+           print *, trim(nf90_strerror(status)) 
+        endif ! opt arg
+        print *,'(get_mod_grid)'
+     endif ! only master outputs
+     call stop_mpi()
+  end if ! check error status
+end subroutine handle_err
+
+end module  m_get_mod_grid

EnKF-MPI-TOPAZ/m_get_mod_nrens.F90

@@ -0,0 +1,76 @@
+module m_get_mod_nrens
+! Finds how many ensemble members there are by counting ocean
+! and ice restart files. 
+! 
+! If an optional integer vector 'enslist' is submitted, the 
+! numbers of the 'still living' members is returned.
+!
+#if defined (QMPI)
+   use qmpi, only : stop_mpi, master
+#else
+   use qmpi_fake, only : stop_mpi, master
+#endif
+
+contains
+
+subroutine get_mod_nrens(nrens, enslist)
+   implicit none
+
+   ! In/out
+   integer,               intent(inout) :: nrens
+   integer, dimension(:), intent(out), optional :: enslist
+
+   ! Local variables
+   logical                ex
+   integer                iens          ! loop var
+   character(len=3)    :: cens          ! contains '1xx' of member
+   character(len=99)   :: path2mod='./' ! should model output be somewhere else
+   integer             :: maxnrens=899  ! max nr of members we're looking for
+#if defined (ICE)
+   integer                nrice         ! ice file counter
+#endif
+
+   ! restart files will have been moved to path2mod and be called
+   ! 'forecast_ice_XXX.nc' where XXX is the enseble identifier (101-)
+
+   ! Count members. Assumed nrens at most 1000.
+   nrens = 0
+   do iens=1,maxnrens
+      write(cens,'(i3.3)') iens+100
+      inquire(exist=ex,file=trim(path2mod)//'forecast_oce_'//cens//'.nc')
+      if (ex) then
+         nrens = nrens + 1
+         if (present(enslist)) enslist(nrens) = iens
+      end if
+   end do
+
+   ! Warn if arbitrary max. limit of nrens is reached.
+   if ( ( nrens.eq.maxnrens ).and.(master) ) then
+      print *,'WARNING:'
+      print *,'WARNING: Ensemble sizes above ',maxnrens,' are not recognized.'
+      print *,'WARNING: Adjust m_get_mod_nrens.F90 to go bigger.'
+      ! Don't forget to adjust also length of cens.
+      print *,'WARNING:'
+   endif
+
+#if defined (ICE)
+   ! Count ice members. Assumed nrens at most maxnrens.
+   nrice = 0
+   do iens=1,maxnrens
+      write(cens,'(i3.3)') iens+100
+      inquire(exist=ex,file=trim(path2mod)//'forecast_ice_'//cens//'.nc')
+      if (ex) nrice = nrice + 1
+   end do
+
+   if (nrice /= nrens) then
+      if (master) then
+         print *,'(get_mod_nrens) Error: Different number of ocean and ice restarts!!!'
+         print *,'Ocean restarts : ',nrens
+         print *,'Ice restarts   : ',nrice
+      end if
+      call stop_mpi()
+   end if
+#endif
+
+end subroutine get_mod_nrens
+end module m_get_mod_nrens

EnKF-MPI-TOPAZ/m_get_mod_xyz.F90

@@ -0,0 +1,99 @@
+module m_get_mod_xyz
+! Gets model dimensions in file './mask.nc' 
+! (unless another netcdf file is submitted) and returns them.
+! Added by F. Massonnet to the NERSC-ENKF routines, May 2013.
+! (Presumably) Coded by C. König Beatty, in 2009
+! Goal is to quickly retrieve model dimensions without using parseblk
+
+  use netcdf
+#if defined (QMPI)
+  use qmpi
+#else
+  use qmpi_fake
+#endif
+
+  private handle_err
+
+contains 
+  subroutine get_mod_xyz(x, y, z, moddimfilein)
+
+  implicit none
+
+  ! In/out
+  integer,          intent(out)          :: x, y, z
+  character(len=*), intent(in), optional :: moddimfilein
+
+  ! NetCDF vars
+  integer            :: ncid, dimID, error
+  character(len=120) :: moddimfile
+
+  logical ex
+
+
+  if (present(moddimfilein)) then
+     moddimfile=moddimfilein
+  else
+     moddimfile='./mask.nc'
+  end if
+
+  ! check the netCDF file exists
+  inquire(file=moddimfile, exist=ex)
+  if (.not.ex) then
+     if (master) then
+        print *, '(get_mod_xyz): file does not exist: '//trim(moddimfile)
+     end if
+     call stop_mpi()
+  end if
+
+
+  ! open the netCDF file
+  error = nf90_open(trim(moddimfile),nf90_NoWrite,ncid)
+  if (error.ne.nf90_noerr) call handle_err(error, "opening")
+
+
+  ! Find DimID of x
+  error = nf90_inq_dimid(ncid, 'x', dimID)
+  if (error.ne.nf90_noerr) call handle_err(error, "inquiring dimID x")
+  ! Get size of dimension
+  error = nf90_inquire_dimension(ncid, dimID, len = x)
+  if (error.ne.nf90_noerr) call handle_err(error, "getting dimension x")
+
+  ! Find DimID of y
+  error = nf90_inq_dimid(ncid, 'y', dimID)
+  if (error.ne.nf90_noerr) call handle_err(error, "inquiring dimID y")
+  ! Get size of dimension
+  error = nf90_inquire_dimension(ncid, dimID, len = y)
+  if (error.ne.nf90_noerr) call handle_err(error, "getting dimension y")
+
+  ! Find DimID of z
+  error = nf90_inq_dimid(ncid, 'z', dimID)
+  if (error.ne.nf90_noerr) call handle_err(error, "inquiring dimID z")
+  ! Get size of dimension
+  error = nf90_inquire_dimension(ncid, dimID, len = z)
+  if (error.ne.nf90_noerr) call handle_err(error, "getting dimension z")
+
+
+  ! Close file
+  error = nf90_close(ncid)              ! close netCDF dataset
+  if (error.ne.nf90_noerr) call handle_err(error, "closing")
+
+
+contains
+
+  subroutine handle_err(status, infomsg) 
+    integer,            intent ( in) :: status 
+    character(len = *), intent ( in), optional :: infomsg
+    if(status /= nf90_noerr) then
+       if (present(infomsg)) then
+          print *, 'Error while '//infomsg//' - '//trim(nf90_strerror(status)) 
+       else
+          print *, trim(nf90_strerror(status)) 
+       endif
+       stop " Stopped" 
+    end if
+  end subroutine handle_err
+
+end subroutine get_mod_xyz
+
+end module m_get_mod_xyz
+

EnKF-MPI-TOPAZ/m_insitu.F90

@@ -0,0 +1,788 @@
+! File:          m_insitu.F90
+!
+! Created:       6 Feb 2008
+!
+! Last modified: 13 Feb 2008
+!
+! Author:        Pavel Sakov
+!                NERSC
+!
+! Purpose:       The code to deal with insitu observations.
+!
+! Description:   This module contains the following subroutines:
+!                  - insitu_setprofiles
+!                      breaks the measurements into profiles and returns
+!                      arrays of start and end indices for each profile
+!                  - insitu_writeprofiles
+!                      writes profiles to a netCDF file
+!                  - insitu_prepareobs
+!                      sorts out the measurements within profiles so they
+!                      go in surface to bottom order and thins the measurements
+!                      by keeping max 1 measurements per layer of the first
+!                      ensemble member
+!                It also contains the following data:
+!                  nprof
+!                    - the number of profiles
+!                  pstart(nprof)
+!                    - start indices for each profile in the array "obs" of
+!                      type(measurement) stored in module m_obs
+!                  pend(nprof)
+!                    - end indices for each profile
+!
+! Modifications:
+!                30/7/2010 PS: added profile pivot points to profile output
+!                  files (SAL.nc etc.)
+!                29/7/2010 PS: some rather minor changes, including interface
+!                  of insitu_writeforecast()
+!                13/02/2008 PS: added insitu_writeprofiles()
+!                26/02/2008 PS: put "nprof", "pstart" and "pend" as public data
+!                  in this module
+!                20/04/2008 PS: added insitu_QC() and insitu_writeforecast()
+!                29/07/2010 PS: removed insitu_QC(). There is a generic obs QC
+!                  procedure in m_obs.F90 now.
+
+module m_insitu
+  use mod_measurement
+  !use m_parse_blkdat
+  use m_get_mod_xyz
+  use m_get_mod_fld
+  use m_io_mod_fld
+#if defined (QMPI)
+   use qmpi
+#else
+   use qmpi_fake
+#endif
+  implicit none
+
+  !
+  ! public stuff
+  !
+  integer, allocatable, dimension(:), public :: pstart
+  integer, allocatable, dimension(:), public :: pend
+  integer, public :: nprof
+
+  public insitu_setprofiles
+  public insitu_prepareobs
+  public insitu_writeprofiles
+
+  !
+  ! private stuff
+  !
+
+  real, parameter, private :: ONEMETER = 9806.0
+  integer, parameter, private :: STRLEN = 512
+
+  ! The portion of the layer thickness at which the variability in
+  ! vertical data will be used for estimating the vertical representativeness
+  ! error.
+  !
+  real, parameter, private :: VARCOEFF1 = 0.15
+  
+  ! A factor by which a calculated vertical representativeness error variance
+  ! will be reduced if the data is in different layers
+  !
+  real, parameter, private :: VARCOEFF2 = 2.0
+
+  ! Write information about this profile. Set to < 1 to switch off.
+  !
+  integer, parameter, private :: PDEBUGINFO = 0
+
+  ! Integers used to tag the fields (to avoid parsing the string tags)
+  !
+  integer, parameter, private :: NONE = 0
+  integer, parameter, private :: TEMPERATURE = 1
+  integer, parameter, private :: SALINITY = 2
+
+  real, parameter, private :: TEM_MIN = -2.0
+  real, parameter, private :: TEM_MAX = 35.0
+  real, parameter, private :: SAL_MIN = 5.0
+  real, parameter, private :: SAL_MAX = 41.0
+
+  ! Maximum allowed deviation between the observation and ensemble mean in
+  ! terms of combined standard deviation.
+  !
+  real, parameter, private :: SAL_MAXRATIO = 10.0
+  real, parameter, private :: TEM_MAXRATIO = 5.0
+
+  ! If an observation is not considered an outlier, the observation error
+  ! variance is modified so that the distance between the observation and the
+  ! endemble mean is within DIST_MAX * sqrt(sigma_obs^2 + sigma_ens^2).
+  ! Bigger values of DIST_MAX result in a more violent assimilation.
+  !
+  real, parameter, private :: DIST_MAX = 2.0
+
+contains
+
+  ! Work out the number of profiles, each identified by "obs % i_orig_grid"
+  ! and return start id of the first and the last obs in the profile in
+  ! arrays "pstart" and "pend". "pstart" and "pend" are publicly available
+  ! arrays stored in this module.
+  !
+  subroutine insitu_setprofiles(obstag, nobs, obs)
+    character(*), intent(in) :: obstag
+    integer, intent(in) :: nobs
+    type(measurement), dimension(:), intent(inout) :: obs
+
+    integer, allocatable, dimension(:) :: tmp, tmp1
+    integer :: o, o1, o2, p, nobsp
+    type(measurement), allocatable, dimension(:) :: tmpobs
+
+    if (nobs == 0) then
+       return
+    end if
+
+    if (allocated(pstart)) then
+       deallocate(pstart)
+       deallocate(pend)
+    end if
+
+    ! find the very first obs of the right kind
+    !
+    o1 = 1
+    do while (trim(obs(o1) % id) /= trim(obstag) .and. o1 <= nobs)
+       o1 = o1 + 1
+    end do
+
+    if (o1 > nobs) then
+       return
+    end if
+
+    ! find the very last obs of the right kind
+    !
+    o2 = nobs
+    do while (trim(obs(o2) % id) /= trim(obstag) .and. o2 >= 0)
+       o2 = o2 - 1
+    end do
+
+    nprof = 1
+    do o = 2, o2
+       if (obs(o) % ipiv /= obs(o - 1) % ipiv .or.&
+            obs(o) % jpiv /= obs(o - 1) % jpiv .or.&
+            obs(o) % date /= obs(o - 1) % date) then
+          nprof = nprof + 1
+       end if
+    end do
+
+    allocate(pstart(nprof))
+    allocate(pend(nprof))
+
+    ! identify profiles
+    !
+    ! PS: This is a tricky cycle but it seems it is doing the job. Do not
+    ! meddle with it.
+    !
+    pend = 0
+    nprof = 1
+    pstart(1) = o1
+    do o = o1, o2
+       ! find obs from the same profile
+       !
+       if (trim(obs(o) % id) == trim(obstag) .and.&
+            ((obs(o) % i_orig_grid > 0 .and.&
+            obs(o) % i_orig_grid == obs(pstart(nprof)) % i_orig_grid) .or.&
+            (obs(o) % i_orig_grid <= 0 .and.&
+            obs(o) % ipiv == obs(pstart(nprof)) % ipiv .and.&
+            obs(o) % jpiv == obs(pstart(nprof)) % jpiv .and.&
+            obs(o) % date == obs(pstart(nprof)) % date))) then
+          pend(nprof) = o
+          cycle
+       end if
+
+       if (trim(obs(o) % id) /= trim(obstag)) then
+          print *, 'ERROR: insitu_setprofiles(): obs id does not match processed obs tag'
+          stop
+       end if
+
+       ! if there were no obs of the right type in this profile yet,
+       ! then pend(nprof) has not been set yet and therefore the condition
+       ! below will yield "false"
+       !
+       if (pend(nprof) >= pstart(nprof)) then
+          nprof = nprof + 1
+       end if
+
+       if (PDEBUGINFO > 0) then
+          print *, '  DEBUG: new profile #', nprof, ', o =', o, ', id =', obs(o) % i_orig_grid
+       end if
+       pstart(nprof) = o
+       pend(nprof) = o
+    end do
+    if (pend(nprof) < pstart(nprof)) then
+       nprof = nprof - 1
+    end if
+
+    ! truncate "pstat" and "pend" to length "nprof"
+    !
+    allocate(tmp(nprof))
+    tmp = pstart(1 : nprof)
+    deallocate(pstart)
+    allocate(pstart(nprof))
+    pstart = tmp
+    tmp = pend(1 : nprof)
+    deallocate(pend)
+    allocate(pend(nprof))
+    pend = tmp
+    deallocate(tmp)
+
+    ! for glider data - sort observations in each profile by increasing depth
+    !
+    if (trim(obstag) == 'GSAL'.or. trim(obstag) == 'GTEM') then
+       allocate(tmp(nobs))
+       allocate(tmp1(nobs))
+       allocate(tmpobs(nobs))
+       do p = 1, nprof
+          nobsp = pend(p) - pstart(p) + 1
+          do o = 1, nobsp
+             tmp(o) = o
+          end do
+          !
+          ! (using procedure from pre_local_analysis())
+          !
+          call order(dble(nobsp), obs(pstart(p) : pend(p)) % depth,&
+               dble(nobsp), tmp, tmp1)
+          tmpobs(1 : nobsp) = obs(pstart(p) : pend(p))
+          do o = 1, nobsp
+             obs(pstart(p) + o - 1) = tmpobs(tmp1(o))
+          end do
+       end do
+       deallocate(tmp, tmp1, tmpobs)
+    end if
+  end subroutine insitu_setprofiles
+
+
+  ! 1. Sort out the obs within profiles so that they are stored in order of
+  !    increasing depth.
+  ! 2. Thin observations by keeping a single obs within a layer using the
+  !    layers from the first ensemble member
+  !
+  subroutine insitu_prepareobs(obstag, nobs, obs)
+    character(*), intent(in) :: obstag
+    integer, intent(inout) :: nobs
+    type(measurement), dimension(:), intent(inout) :: obs
+
+    ! profiles
+    !
+    integer, allocatable, dimension(:) :: pnow
+    integer :: nobs_max
+
+    integer :: p, o
+    type(measurement), allocatable, dimension(:) :: profile
+
+    integer, allocatable, dimension(:) :: ipiv, jpiv
+    real, allocatable, dimension(:) :: a1, a2, a3, a4
+    real, allocatable, dimension(:) :: z1, z2
+
+    integer :: nrev
+    integer :: ndel
+    integer :: oo
+    real :: rdummy
+    integer :: k, nk, ni, nj
+    character(80) :: fname
+    integer :: tlevel
+    real, allocatable, dimension(:, :) :: dz2d
+    real, dimension(2, 2) :: dz_cell
+    real :: dz, zcentre
+    integer :: best
+    logical :: isrogue
+
+    ! As we thin the measurements within each layer, it still may be a good
+    ! idea to update the obs error variance if the variability within the layer
+    ! is big enough. `dmin' and `dmax' give the min and max measured values
+    ! within the layer.
+    !
+    real :: dmin, dmax
+    real :: var1, var2
+
+    integer :: nobsnew, nobs_thistype, nobs_othertype
+    
+    if (master) then
+       print '(a, a, a)', '   insitu_prepareobs(', trim(obstag), '):'
+       print '(a, i6)', '     total # of obs = ', nobs
+    end if
+
+    if (nobs == 0) then
+       return
+    end if
+
+    call insitu_setprofiles(trim(obstag), nobs, obs)
+
+    if (master) then
+       print '(a, a, a, i6)', '     # of obs of type "', trim(obstag), '" = ',&
+            sum(pend(1 : nprof) - pstart(1 : nprof)) + nprof
+       print '(a, i4)', '     # of profiles = ', nprof
+    end if
+
+    ! find the maximal # of obs in a single profile
+    !
+    nobs_max = 0
+    do p = 1, nprof
+       nobs_max = max(nobs_max, pend(p) - pstart(p) + 1)
+    end do
+
+    if (master) then
+       print '(a, i4)', '     max # of obs in a profile before thinning = ', nobs_max
+    end if
+
+    ! reverse the obs in profiles that go from bottom to surface
+    !
+    allocate(profile(nobs_max))
+    nrev = 0
+    do p = 1, nprof
+       if (obs(pstart(p)) % depth > obs(pend(p)) % depth) then
+          
+          profile(1 : pend(p) - pstart(p) + 1) = obs(pstart(p) : pend(p))
+          do o = 0, pend(p) - pstart(p)
+             obs(pstart(p) + o) = profile(pend(p) - o)
+          end do
+          nrev = nrev + 1
+       end if
+    end do
+    deallocate(profile)
+
+    if (nrev > 0 .and. master) then
+       print *, '  ', nrev, ' profile(s) reversed'
+    end if
+
+    ! check for rogue obs
+    !
+    ndel = 0
+    do p = 1, nprof
+       isrogue = .false. 
+       do o = pstart(p) + 1, pend(p)
+
+          ! shift the remaining obs in this profile one obs down
+          !
+          if (obs(o) % depth <= obs(o - 1) % depth) then
+             isrogue = .true. 
+             do oo = o + 1, pend(p)
+                obs(oo - 1) = obs(oo)
+             end do
+             ndel = ndel + 1
+             pend(p) = pend(p) - 1
+          end if
+       end do
+       if (isrogue .and. master) then 
+          print *, '  a rogue obs detected in profile # ', p 
+       end if  
+    end do
+
+    if (ndel > 0 .and. master) then
+       print *, '  ', ndel, 'rogue obs deleted'
+    end if
+
+    !
+    ! Now to the thinning of the profiles.
+    !
+
+    allocate(ipiv(nprof))
+    allocate(jpiv(nprof))
+    allocate(a1(nprof))
+    allocate(a2(nprof))
+    allocate(a3(nprof))
+    allocate(a4(nprof))
+
+    ipiv = obs(pstart(1 : nprof)) % ipiv
+    jpiv = obs(pstart(1 : nprof)) % jpiv
+    a1 = obs(pstart(1 : nprof)) % a1
+    a2 = obs(pstart(1 : nprof)) % a2
+    a3 = obs(pstart(1 : nprof)) % a3
+    a4 = obs(pstart(1 : nprof)) % a4
+
+    ! get the grid dimensions
+    !
+    !call parse_blkdat('kdm   ','integer', rdummy, nk)
+    !call parse_blkdat('idm   ','integer', rdummy, ni)
+    !call parse_blkdat('jdm   ','integer', rdummy, nj)
+    call get_mod_xyz(ni, nj, nk) ! CKB,FM Changed from using m_parse_blkdat
+
+    ! get the data file name
+    !
+    if (trim(obstag) /= 'SAL' .and. trim(obstag) /= 'TEM' .and.&
+         trim(obstag) /= 'GSAL'.and. trim(obstag) /= 'GTEM') then
+       print *, 'ERROR: get_S(): unknown observation tag "', trim(obstag), '"'
+       stop
+    end if
+    fname = 'forecast001'
+
+    allocate(z1(nprof))
+    allocate(z2(nprof))
+    allocate(pnow(nprof))
+    allocate(dz2d(ni, nj))
+
+    ! data thinning cycle
+    !
+    if (master) then
+       print *, '  maximum one observation per layer will be retained after thinning'
+    end if
+    tlevel = 1
+    z1 = 0.0
+    pnow = pstart
+    if (master .and. PDEBUGINFO > 0) then
+       p = PDEBUGINFO
+       print *, 'DEBUG dumping the info for profile #', p
+       print *, 'DEBUG   p =', p, ': lon =', obs(pstart(p)) % lon, ', lat =', obs(pstart(p)) % lat
+       print *, 'DEBUG now dumping the layer depths:'
+    end if
+
+    ! mark all obs of this type as bad; unmask the best obs within a layer
+    !
+    do o = 1, nobs
+       if (trim(obs(o) % id) == trim(obstag)) then
+          obs(o) % status = .false.
+       end if
+    end do
+    do k = 1, nk
+       !call get_mod_fld_new(trim(fname), dz2d, 1, 'dp      ', k, tlevel, ni, nj)
+       ! [CKB,FM]
+       call io_mod_fld(dz2d, 1, (/ 1 /), 'dp      ', 2, &
+            k, tlevel, ni, nj, 'get',FLOAT(obs(1)%date))
+       do p = 1, nprof
+          dz_cell(:, :) = dz2d(ipiv(p) : ipiv(p) + 1, jpiv(p) : jpiv(p) + 1)
+          dz = dz_cell(1, 1) * a1(p) + dz_cell(2, 1) * a2(p)&
+               + dz_cell(1, 2) * a3(p) + dz_cell(2, 2) * a4(p)
+          dz = dz / ONEMETER
+          z2(p) = z1(p) + dz
+          zcentre = (z1(p) + z2(p)) / 2.0
+          best = -1
+          dmin = 1.0d+10
+          dmax = -1.0d+10
+          if (master .and. PDEBUGINFO > 0 .and. p == PDEBUGINFO) then
+             print *, 'DEBUG   p =', p, ', k =', k, ', z =', z1(p), '-', z2(p)
+          end if
+          do while (pnow(p) <= pend(p))
+             o = pnow(p)
+             
+             ! check that the depth is within the layer
+             !
+             if (obs(o) % depth > z2(p)) then
+                ! go to next profile; this obs will be dealt with when
+                ! processing the next layer
+                exit
+             end if
+
+             ! from this point on, the obs counter will be increased at the
+             ! end of this loop
+
+             ! store profile and layer number (overwrite the original profile
+             ! id and vertical counter value)
+             !
+             obs(o) % i_orig_grid = p
+             obs(o) % j_orig_grid = k
+             obs(o) % h = z2(p) - z1(p)
+
+             if (obs(o) % depth < z1(p)) then
+                pnow(p) = pnow(p) + 1
+                cycle ! next obs
+             end if
+
+             ! update `dmin' and `dmax'
+             !
+             dmin = min(dmin, obs(o) % d)
+             dmax = max(dmax, obs(o) % d)
+
+             if (best < 1) then
+                best = o
+                obs(best) % status = .true.
+             else if (abs(obs(o) % depth - zcentre) < abs(obs(best) % depth - zcentre)) then
+                obs(best) % status = .false. ! thrash the previous best obs
+                best = o
+                obs(best) % status = .true.
+             end if
+             pnow(p) = pnow(p) + 1
+          end do ! o
+
+          ! update the observation error variance if the difference between
+          ! `dmin' and `dmax' is big enough
+          !
+          if (best < 1) then
+             cycle
+          end if
+
+          if (.false.) then ! out for now; use the closest obs instead
+             if (dmax - dmin > 0) then
+                obs(best) % var = sqrt(obs(best) % var + ((dmax - dmin) / 2) ** 2)
+             end if
+          end if
+       end do ! p
+       z1 = z2
+    end do ! k
+
+    ! There are a number of ways the vertical variability can be
+    ! used for updating the obs error variance.
+    !
+    ! Below, the following approach is used.
+    !
+    ! Calculate two estimates for vertical gradient using the closest data
+    ! points (if available). Estimate the difference at (VARCOEFF1 * h)
+    ! vertical distance from the current obs, where VARCOEFF1 is the portion
+    ! of the layer thickness (typically around 0.1-0.3), and h is the layer
+    ! thickness. Use the square of this difference as an estimate for the
+    ! respresentation error variance. If the closest obs is in another layer
+    ! -- decrease this estimate by a factor of VARCOEFF2 (typically around 2).
+    ! Use the largest estimate between the two (when both are avalaible).
+    !
+     do p = 1, nprof
+       do o = pstart(p), pend(p)
+          k = obs(o) % j_orig_grid
+          if (obs(o) % status) then
+             var1 = -999.0
+             var2 = -999.0
+             if (o - 1 >= pstart(p)) then
+                var1 = ((obs(o) % d - obs(o - 1) % d) /&
+                     (obs(o) % depth - obs(o - 1) % depth) * obs(o) % h * VARCOEFF1) ** 2
+                if (obs(o - 1) % j_orig_grid /= k) then
+                   var1 = var1 / VARCOEFF2
+                end if
+             end if
+             if (o + 1 <= pend(p)) then
+                var2 = ((obs(o) % d - obs(o + 1) % d) /&
+                     (obs(o) % depth - obs(o + 1) % depth) * obs(o) % h * VARCOEFF1) ** 2
+                if (obs(o + 1) % j_orig_grid /= k) then
+                   var2 = var2 / VARCOEFF2
+                end if
+             end if
+             if (var1 < 0.0 .and. var2 < 0.0) then
+                cycle
+             end if
+             obs(o) % var = obs(o) % var + max(var1, var2)
+          end if
+       end do
+    end do
+
+    if (master .and. PDEBUGINFO > 0) then
+       p = PDEBUGINFO
+       print *, 'DEBUG now dumping the obs info:'
+       do o = pstart(p), pend(p)
+          print *, 'DEBUG   o =', o, ', status =', obs(o) % status, &
+               ', d =', obs(o) % d, ', z =', obs(o) % depth,&
+               ', k =', obs(o) %  j_orig_grid, ',  h =', obs(o) % h,&
+               ', var =', obs(o) % var
+       end do
+    end if
+
+    deallocate(dz2d)
+    deallocate(pnow)
+    deallocate(z2)
+    deallocate(z1)
+    deallocate(a4)
+    deallocate(a3)
+    deallocate(a2)
+    deallocate(a1)
+    deallocate(jpiv)
+    deallocate(ipiv)
+
+    ! now compact the obs array
+    !
+    nobsnew = 0
+    nobs_thistype = 0
+    nobs_othertype = 0
+    do o = 1, nobs
+       if (obs(o) % status) then
+          nobsnew = nobsnew + 1
+          obs(nobsnew) = obs(o)
+          if (trim(obs(o) % id) == trim(obstag)) then
+             nobs_thistype = nobs_thistype + 1
+          else
+             nobs_othertype = nobs_othertype + 1
+          end if
+       end if
+    end do
+    obs(nobsnew + 1 : nobs) % status = .false.
+    nobs = nobsnew
+
+    ! replace the original profiles by the thinned ones
+    !
+    call insitu_setprofiles(trim(obstag), nobs, obs)
+
+    if (master) then
+       print *, '  thinning completed:', nobs_thistype, ' "', trim(obstag), '" obs retained'
+       if (nobs_othertype > 0) then
+          print *, '  ', nobs_othertype, 'obs of other type(s) retained'
+       end if
+    end if
+  end subroutine insitu_prepareobs
+
+
+  ! Write profiles to a NetCDF file
+  !
+  subroutine insitu_writeprofiles(fname, obstag, nobs, obs)
+    use nfw_mod
+    
+    character(*), intent(in) :: fname
+    character(*), intent(in) :: obstag
+    integer, intent(inout) :: nobs
+    type(measurement), dimension(:), intent(inout) :: obs
+
+    ! profiles
+    !
+    integer :: p
+    integer :: npoints, npoints_max
+
+    ! I/O
+    !
+    integer :: ncid
+    integer :: nprof_id(1), nk_id(1), dids(2)
+    integer :: lat_id, lon_id, ipiv_id, jpiv_id, npoints_id, depth_id, v_id, variance_id
+    character(STRLEN) :: varname
+
+    real(8), allocatable, dimension(:, :) :: v
+
+    if (.not. allocated(pstart)) then
+       call insitu_setprofiles(trim(obstag), nobs, obs)
+    end if
+
+    call nfw_create(fname, nf_write, ncid)
+
+    call nfw_def_dim(fname, ncid, 'nprof', nprof, nprof_id(1))
+    call nfw_def_var(fname, ncid, 'lat', nf_double, 1, nprof_id, lat_id)
+    call nfw_def_var(fname, ncid, 'lon', nf_double, 1, nprof_id, lon_id)
+    call nfw_def_var(fname, ncid, 'ipiv', nf_int, 1, nprof_id, ipiv_id)
+    call nfw_def_var(fname, ncid, 'jpiv', nf_int, 1, nprof_id, jpiv_id)
+    call nfw_def_var(fname, ncid, 'npoints', nf_int, 1, nprof_id, npoints_id)
+    npoints_max = maxval(pend - pstart) + 1
+    call nfw_def_dim(fname, ncid, 'nk', npoints_max, nk_id(1))
+    dids(1) = nk_id(1)
+    dids(2) = nprof_id(1)
+    call nfw_def_var(fname, ncid, 'depth', nf_double, 2, dids, depth_id)
+    if (trim(obstag) == 'SAL' .or. trim(obstag) == 'GSAL') then
+       varname = 'salt'
+    else if (trim(obstag) == 'TEM' .or. trim(obstag) == 'GTEM') then
+       varname = 'temp'
+    else
+       varname = trim(obstag)
+    end if
+    call nfw_def_var(fname, ncid, trim(varname), nf_double, 2, dids, v_id)
+    call nfw_def_var(fname, ncid, 'variance', nf_double, 2, dids, variance_id)
+
+    call nfw_enddef(fname, ncid)
+
+    call nfw_put_var_double(fname, ncid, lat_id, obs(pstart) % lat)
+    call nfw_put_var_double(fname, ncid, lon_id, obs(pstart) % lon)
+    call nfw_put_var_int(fname, ncid, ipiv_id, obs(pstart) % ipiv)
+    call nfw_put_var_int(fname, ncid, jpiv_id, obs(pstart) % jpiv)
+    call nfw_put_var_int(fname, ncid, npoints_id, pend - pstart + 1)
+
+    ! depth
+    !
+    allocate(v(npoints_max, nprof))
+    v = -999.0
+    do p = 1, nprof
+       npoints = pend(p) - pstart(p) + 1
+       v(1 : npoints, p) = obs(pstart(p) : pend(p)) % depth
+    end do
+    call nfw_put_var_double(fname, ncid, depth_id, v)
+    
+    ! data
+    !
+    v = -999.0
+    do p = 1, nprof
+       npoints = pend(p) - pstart(p) + 1
+       v(1 : npoints, p) = obs(pstart(p) : pend(p)) % d
+    end do
+    call nfw_put_var_double(fname, ncid, v_id, v)
+    
+    ! data error variance
+    !
+    v = -999.0
+    do p = 1, nprof
+       npoints = pend(p) - pstart(p) + 1
+       v(1 : npoints, p) = obs(pstart(p) : pend(p)) % var
+    end do
+    call nfw_put_var_double(fname, ncid, variance_id, v)
+
+    call nfw_close(fname, ncid)
+
+    deallocate(v)
+    deallocate(pstart)
+    deallocate(pend)
+  end subroutine insitu_writeprofiles
+
+
+  ! This subroutine appends the interpolated ensemble mean and the ensemble
+  ! error variance to the assimilated profile data SAL.nc or TEM.nc. It also
+  ! overwrites the observation error variance with latest values.
+  !
+  subroutine insitu_writeforecast(obstag, nobs, nrens, S, obs)
+    use nfw_mod
+    implicit none
+
+    character(*), intent(in) :: obstag
+    integer, intent(in) :: nobs
+    integer, intent(in) :: nrens
+    real, dimension(nobs, nrens), intent(in) :: S
+    type(measurement), dimension(nobs), intent(inout) :: obs
+    
+    character(STRLEN) :: fname
+    real, dimension(nobs) :: Smean, Svar
+    integer :: i, p
+
+    integer :: ncid
+    integer :: dids(2)
+    integer :: v_id, variance_id
+    integer :: npoints_max, npoints
+    real(8), allocatable, dimension(:, :) :: v
+
+    ! need to set profiles for the given observation type
+    !
+    call insitu_setprofiles(obstag, nobs, obs)
+
+    write(fname, '(a, ".nc")') trim(obstag)
+    print *, 'Appending interpolated forecast for "', trim(obstag),&
+         '" to "', trim(fname), '"'
+
+    Smean = sum(S, DIM = 2) / nrens
+    Svar = 0.0
+    do i = 1, nobs
+       Svar(i) = sum((S(i, :) - Smean(i)) ** 2)
+    end do
+    Svar = Svar / real(nrens - 1)
+
+    call nfw_open(fname, nf_write, ncid)
+    
+    call nfw_inq_dimid(fname, ncid, 'nk', dids(1))
+    call nfw_inq_dimid(fname, ncid, 'nprof', dids(2))
+
+    call nfw_redef(fname, ncid)
+
+    call nfw_def_var(fname, ncid, 'forecast', nf_double, 2, dids, v_id)
+    call nfw_def_var(fname, ncid, 'forecast_variance', nf_double, 2, dids, variance_id)
+
+    call nfw_enddef(fname, ncid)
+
+    npoints_max = maxval(pend - pstart) + 1
+    allocate(v(npoints_max, nprof))
+
+    v = -999.0
+    do p = 1, nprof
+       npoints = pend(p) - pstart(p) + 1
+       v(1 : npoints, p) = Smean(pstart(p) : pend(p))
+    end do
+    call nfw_put_var_double(fname, ncid, v_id, v)
+
+    v = -999.0
+    do p = 1, nprof
+       npoints = pend(p) - pstart(p) + 1
+       v(1 : npoints, p) = Svar(pstart(p) : pend(p))
+    end do
+    call nfw_put_var_double(fname, ncid, variance_id, v)
+
+    ! update observation error variance
+    !
+    call nfw_redef(fname, ncid)
+    call nfw_rename_var(fname, ncid, 'variance', 'variance_orig')
+    call nfw_def_var(fname, ncid, 'variance', nf_double, 2, dids, variance_id)
+    call nfw_enddef(fname, ncid)
+
+    v = -999.0
+    do p = 1, nprof
+       npoints = pend(p) - pstart(p) + 1
+       v(1 : npoints, p) = obs(pstart(p) : pend(p)) % var
+    end do
+    call nfw_put_var_double(fname, ncid, variance_id, v)
+
+    call nfw_close(fname, ncid)
+
+    deallocate(v)
+  end subroutine insitu_writeforecast
+
+end module m_insitu

EnKF-MPI-TOPAZ/m_io_mod_fld.F90

@@ -0,0 +1,163 @@
+module m_io_mod_fld
+! Get or put one of the fields of a restart file, specified by
+! ensemble number, field name and type, and vertical level. The 
+! time level is currently not used (restart files have only one)
+! but who knows. Grid dimension is also needed, as well as if you
+! want to 'get' or 'put'.
+!
+! This replaces the two routines 'm_get_mod_fld.F90' and m_put_mod_fld.F90'.
+! There was so much overlap that it became easier to merge the two. I think.
+!
+! (c) July 2009, Christof.KonigBeatty@uclouvain.be
+
+  use netcdf
+#if defined (QMPI)
+  use qmpi
+#else
+  use qmpi_fake
+#endif
+
+  private handle_err
+
+
+contains 
+  subroutine io_mod_fld(fld,k,enslist,cfld,type,vlevel,tlevel,nx,ny,gorp,rdate_obs)
+
+  implicit none
+
+  ! In/out
+  real,dimension(nx,ny),intent(inout):: fld    ! output fl
+  integer,                intent(in) :: k      ! Index to enslist
+  integer,dimension(:),   intent(in) :: enslist! List of existing ensemble members
+  character(len=*),       intent(in) :: cfld   ! name of fld
+  integer,                intent(in) :: type   ! which file to use
+  integer,                intent(in) :: vlevel ! vertical level (ignored)
+  integer,                intent(in) :: tlevel ! time level (ignored)
+  integer,                intent(in) :: nx,ny  ! Grid dimension
+  character(len=3),       intent(in) :: gorp   ! 'get' or 'put' (sorry, couldn't come up with anything better)
+  real(kind=8),           intent(in) :: rdate_obs
+  ! NetCDF vars
+  integer           :: iens             ! Ensemble member to read
+  character(len=99) :: fcfile, anafile, cfile
+  integer           :: ncid, varID, error
+  logical           :: exfc, exan
+  ! Other
+  character(len=3)  :: cmem
+  integer           :: zvlevel   ! for i/o ocean variable
+  real(kind=8)      :: rdate_mod
+  ! Find iens withing enslist
+  iens = enslist(k)
+
+  ! Create filename dep. on type of variable/parameter requested
+  write(cmem,'(i3.3)') 100+iens  ! iens=1 gives cmem = 101
+  select case( type )
+  case(1) ! ice variable
+     fcfile ='forecast_ice_'//cmem//'.nc'
+     anafile='analysis_ice_'//cmem//'.nc'
+  case(2) ! ocean variable
+     fcfile ='forecast_oce_'//cmem//'.nc'
+     anafile='analysis_oce_'//cmem//'.nc'
+     zvlevel = max(vlevel,1)
+  case(3) ! ice namelist parameter
+     if (master) print *, '(io_mod_fld): ice parameter writing not implemented yet!'
+     call stop_mpi()
+  case(4) ! ocean namelist parameter
+     if (master) print *, '(io_mod_fld): ocean parameter writing not implemented yet!'
+     call stop_mpi()
+  case default
+     if (master) print *, '(io_mod_fld): variable type not understood!'
+     call stop_mpi()
+  end select
+
+
+  ! If the fc file exists we turn it into the analysis file (unless that's already there).
+  inquire(file=fcfile,  exist=exfc)
+  inquire(file=anafile, exist=exan)
+  if ((.not.exfc).and.(.not.exan)) then       ! Neither file is there
+    if (master) print *, '(io_mod_fld): Restart file '//cmem//' missing!'
+    call stop_mpi()
+  elseif (exfc.and.(.not.exan)) then          ! fcfile here but no anafile
+!     call system('mv '//trim(fcfile)//' '//trim(anafile) )  ! "operational" to save space
+     call system('cp '//trim(fcfile)//' '//trim(anafile) )  ! for debugging
+  end if
+  
+  ! Decide on which file to use
+  if (gorp=='get') cfile=fcfile
+  if (gorp=='put') cfile=anafile
+
+  ! ckb prefers only one file at the time, so take care of this special case
+  inquire(file=fcfile,  exist=exfc)
+  if (.not.exfc) cfile=anafile
+
+!!$  !XXX:
+!!$  write(*,*) "XXX: "
+!!$  write(*,*) "XXX: iens           : ", iens
+!!$  write(*,*) "XXX: cfld           : ", cfld
+!!$  write(*,*) "XXX: type           : ", type
+!!$  write(*,*) "XXX: nx, ny, zvlevel: ", nx, ny, zvlevel
+!!$  write(*,*) "XXX: fcfile         : ", trim(fcfile)
+!!$  write(*,*) "XXX: anafile        : ", trim(anafile)
+!!$  write(*,*) "XXX: shape(fldIO)   : ", shape(fldIO)
+!!$  write(*,*) "XXX: "
+!!$  !:XXX
+  
+  ! open the netCDF file
+  error = nf90_open(trim(cfile),nf90_Write,ncid); if (error.ne.nf90_noerr) call handle_err(error, "opening")
+
+  ! Find VarID of cfld
+  error = nf90_inq_varid(ncid, trim(cfld), varID); if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+
+  ! Put/Get
+  select case( type )
+  case(1, 3, 4) ! 2D
+     if     (gorp=='get') then
+        error = nf90_get_var(ncid, varID, fld); if (error.ne.nf90_noerr) call handle_err(error, "getting 2D variable")
+     elseif (gorp=='put') then
+        error = nf90_put_var(ncid, varID, fld); if (error.ne.nf90_noerr) call handle_err(error, "putting 2D variable")
+     else
+        if (master) print *, "(io_mod_fld): Either 'put' or 'get'!"
+        call stop_mpi()
+     endif
+  case(2) ! 3D ocean variable
+     if     (gorp=='get') then
+        error = nf90_get_var(ncid, varID, fld, start=(/1,1,zvlevel/), count=(/nx,ny,1/)); if (error.ne.nf90_noerr) call handle_err(error, "getting ocean variable")
+     elseif (gorp=='put') then
+        error = nf90_put_var(ncid, varID, fld, start=(/1,1,zvlevel/), count=(/nx,ny,1/)); if (error.ne.nf90_noerr) call handle_err(error, "putting ocean variable")
+     else
+        if (master) print *, "(io_mod_fld): Either 'put' or 'get'!"
+        call stop_mpi()
+     endif
+  end select
+
+  !if (master) PRINT *, " Find VarID of cfld "
+  error = nf90_inq_varid(ncid, 'time_counter', varID); if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")
+  error = nf90_get_var(ncid, varID, rdate_mod); if (error.ne.nf90_noerr) call handle_err(error, "getting ocean variable")
+
+  ! Close file
+  error = nf90_close(ncid); if (error.ne.nf90_noerr) call handle_err(error, "closing")
+
+  ! Check date mode and date obs
+  IF (INT(rdate_mod) .NE. INT(rdate_obs)) THEN
+     !PRINT *, 'date mod not egal to date obs, stop, (',INT(rdate_mod),' ',INT(rdate_obs),')'
+     !STOP 1
+  END IF
+end subroutine  io_mod_fld
+
+
+subroutine handle_err(status, infomsg) 
+  integer,            intent ( in) :: status 
+  character(len = *), intent ( in), optional :: infomsg
+  if(status /= nf90_noerr) then
+     if (master) then
+        if (present(infomsg)) then
+           print *, 'Error while '//infomsg//' - '//trim(nf90_strerror(status)) 
+        else
+           print *, trim(nf90_strerror(status)) 
+        endif ! opt arg
+        print *,'(io_mod_fld)'
+     endif ! only master outputs
+     call stop_mpi()
+  end if ! check error status
+end subroutine handle_err
+
+end module  m_io_mod_fld

EnKF-MPI-TOPAZ/m_local_analysis.F90

@@ -0,0 +1,991 @@
+! File:          m_local_analysis.F90
+!
+! Created:       L. Bertino, 2002
+!
+! Last modified: 13/04/2010
+!
+! Purpose:       Local analysis:
+!                  -- calculation of X5
+!                  -- update of the ensemble fields
+!
+! Description:   This module handles local analysis.
+!
+! Modifications:
+!                20/9/2011 PS:
+!                    - modified update_fields() to allow individual inflation
+!                      for each of `nfields' fields - thanks to Ehouarn Simon
+!                      for spotting this inconsistency
+!                25/8/2010 PS:
+!                    - "obs" and "nobs" are now global, stored in m_obs. 
+!                      Accordingly, the local observations variables are now
+!                      called "lobs" and "nlobs". Renamed "DD" to "D" and "d"
+!                      to "dy". 
+!                5/8/2010 PS:
+!                    - moved applying inflation from calc_X5() to
+!                      update_fields()
+!                    - introduced "rfactor" argument to calc_X5() - increases
+!                      obs. error variance for the update of anomalies.
+!                29/7/2010 PS:
+!                    - calc_X5(): updated the list of things that needed to be
+!                      done for a point with no local obs
+!                6/7/2010 PS:
+!                    - moved ij2nc() to p2nc_writeobs() in m_point2nc.F90
+!                19/6/2010 PS:
+!                    - added X5 to the ij2nc() output
+!                25/5/2010 PS:
+!                    - modified to accommodate inflation
+!                    - modified to calculate SRF (spread reduction factor)
+!                13/4/2010 Alok Gupta: added open/close/barrier to ensure that
+!                    X5tmp.uf exists before any node tries to access it.
+!                8/4/2010 PS: replaced "X4" by "X5"; renamed "localanalysis()"
+!                    to "update_fields()", and "pre_local_analysis()" by
+!                    "calc_X5"
+!                1/03/2010 PS:
+!                  - Additional checks for file I/O, as the X4 read/write have
+!                    been demonstrated to fail occasionally. A record is now
+!                    written to X4tmp, then read back and compared until the
+!                    two instances coincide (10 attempts max).
+!                11/11/2009 PS:
+!                  - Changed numerics. Now it is always assumed that R is 
+!                    diagonal
+!                  - Choice of two chemes: EnKF and DEnKF (for now)
+!                  - X4 calculated either in ens or obs space, depending on
+!                    relation between nobs (# of local observations) and nrens
+!                  - dfs and nobs for each (i,j) are written to enkf_diag.nc
+!                  - if TEST = .true. then local stuff for (I,J) around
+!                    (TEST_I, TEST_J) is dumped to enkf_<I>,<J>.nc
+!                6/3/2008 PS:
+!                  - in pre_local_analysis():
+!                    - introduced quick sort (O(n log n)) of pre-selected
+!                      observations
+!                    - reshuffled the interface
+!                    - replaced output array of flags for local obs by an array
+!                      of indices
+!                  - in local_analysis():
+!                      -- unified arrays subD and subS
+!                      -- got rid of calls to getD()
+!                      -- used matmul()
+!                      -- introduced localisation function
+!                      -- eliminated X2 and V
+!                2007 K. A. Liseter and Ragnhild Blikberg:
+!                      -- MPI parallelisation
+
+module m_local_analysis
+  implicit none
+
+  !
+  ! public stuff
+  !
+  real(4), allocatable, public :: X5(:,:,:)
+  real(4), allocatable, public :: X5check(:,:,:)
+
+  public calc_X5
+  public update_fields
+
+  integer, parameter, private :: STRLEN = 512
+  integer, parameter, private :: MAXITER = 10
+
+  integer, private :: nX5pad
+  real(4), allocatable, private :: X5pad(:)
+
+  private get_npad_la
+  private locfun
+  private get_local_obs
+  private diag2nc
+  private traceprod
+ 
+  !
+  ! available localisation functions
+  !
+  integer, parameter, private :: LOCFUN_NONE = 1
+  integer, parameter, private :: LOCFUN_STEP = 2
+  integer, parameter, private :: LOCFUN_GASPARI_COHN = 3
+
+  !
+  ! used localisation function
+  !
+  integer, private :: LOCFUN_USED = LOCFUN_GASPARI_COHN
+
+  !
+  ! available schemes
+  !
+  integer, parameter, private :: SCHEME_ENKF = 1
+  integer, parameter, private :: SCHEME_ETKF = 2 ! not implemented
+  integer, parameter, private :: SCHEME_DENKF = 3
+
+  !
+  ! used scheme
+  !
+  integer, private :: SCHEME_USED = SCHEME_DENKF
+
+contains 
+
+  ! This routine is called for each "field" (horizontal slab) after calcX5().
+  ! It conducts the multiplication
+  !   E^a(i, :) = E^f(i, :) * X5(i), i = 1,...,n,
+  ! where n - state dimension.
+  !
+  ! In this package the localisation is conducted only horizontally, so that
+  ! the local (nrens x nrens) ensemble transform matrix X5 is stored for each
+  ! node of the horizontal model grid. In TOPAZ4 this requires  
+  ! 880 x 800 x 100 x 100 x 4 = 28 GB of storage on disk for "tmpX5.uf". If the
+  ! fileds were updated on one-by-one basis, this file would have to be read
+  ! (in TOPAZ4) 146 times. Therefore, the fields are updated in bunches of
+  ! `nfields' to reduce the load on disk.
+  !
+  subroutine update_fields(ni, nj, nrens, nfields, nobs_array, depths, fld, infls)
+#if defined (QMPI)
+    use qmpi
+#else
+    use qmpi_fake
+#endif
+    use mod_measurement
+    implicit none
+
+    integer, intent(in) :: ni, nj ! size of grid
+    integer, intent(in) :: nrens ! size of ensemble
+    integer, intent(in) :: nfields ! number of 2D fields to be updated
+    integer, dimension(ni, nj), intent(in) :: nobs_array! number of local obs
+    real, dimension(ni, nj), intent(in) :: depths 
+    real(4), dimension(ni * nj, nrens * nfields), intent(inout) :: fld ! fields
+    real, dimension(nfields), intent(in) :: infls ! inflation factors
+
+    real(4), dimension(nrens, nrens) :: X5tmp
+    real(4), dimension(nrens, nrens) :: IM ! inflation matrix
+
+    integer :: m, i, j, f
+    integer :: irecl, iostatus
+    real(4) :: infl
+
+    !KAL -- all nodes open for read access to temporary "X5" file 
+    inquire(iolength = irecl) X5(1 : nrens, 1 : nrens, 1 : ni), X5pad
+    open(17, file = 'tmpX5.uf', form = 'unformatted', access = 'direct',&
+         status = 'old', recl = irecl)
+
+    do j = 1, nj
+       ! read X5 from disk
+       read(17, rec = j, iostat = iostatus) X5
+       if (iostatus /= 0) then 
+          print *, 'ERROR: local_analysis(): I/O error at reading X5, iostatus = ', iostatus
+          print *, 'ERROR: at j = ', j
+          stop
+       end if
+ 
+       do i = 1, ni
+          ! skip this cell if it is on land
+          if (depths(i,j) <= 0.0) then
+             cycle
+          end if
+
+          if (nobs_array(i, j) == 0 .and. all(infls == 1.0d0)) then
+             cycle
+          end if
+
+          X5tmp = X5(:, :, i)
+          do m = 1, nrens
+             if (abs(1.0e0 - sum(X5tmp(:, m))) > 1.0e-5) then
+                print *, 'ERROR: detected inconsistency in X5'
+                print *, 'ERROR: at j = ', j, 'i = ', i
+                print *, 'ERROR: sum(X5(:, ', m, ') = ', sum(X5tmp(:, m))
+                stop
+             end if
+          enddo
+
+          ! ensemble transformation, in real(4)
+          !
+          do f = 1, nfields
+             infl = infls(f) ! conversion to real(4)
+             if (infl /= 1.0) then
+                IM = - (infl - 1.0) / real(nrens, 4)
+                do m = 1, nrens
+                   IM(m, m) = IM(m, m) + infl
+                end do
+
+                fld((j - 1) * ni + i, (f - 1) * nrens + 1 : f * nrens) =&
+                     matmul(fld((j - 1) * ni + i, (f - 1) * nrens + 1 : f * nrens),&
+                     matmul(X5tmp, IM))
+             else
+                fld((j - 1) * ni + i, (f - 1) * nrens + 1 : f * nrens) =&
+                     matmul(fld((j - 1) * ni + i, (f - 1) * nrens + 1 : f * nrens), X5tmp)
+             end if
+          end do
+       enddo
+    enddo
+    close(17)
+  end subroutine update_fields
+
+
+  ! This routine calculates X5 matrices involved in the EnKF analysis, 
+  !   E^a(i, :) = E^f(i, :) * X5(i), i = 1,...,n,
+  ! where n - state dimension.
+  !
+  ! X5(i) is calculated locally (for a given state element i) as 
+  !   X5 = I + G s 1^T + T,
+  ! where
+  !   G = S^T (I + S S^T)^{-1} = (I + S^T S)^{-1} S^T      [ FM ] Very important. This is a reformulation of the EnKF in the ensemble space.
+  !   T = I - 1/2 G S        (DEnKF)                              Details about this can be found in Sakov et al 2010 in which 
+  !                                                               I appended the demonstration
+  !   T = I + G(D - S)       (EnKF)
+  !   T = (I + S^T S)^{-1/2} (ETKF)
+  !   S = R^{-1/2} HA^f / sqrt(m - 1)
+  !   s = R^{-1/2} (d - Hx^f) / sqrt(m - 1)
+  !
+  !   see Sakov et al. (2010): Asynchronous data assimilation with the EnKF,
+  !   Tellus 62A, 24-29.
+  !
+  subroutine calc_X5(nrens, modlon, modlat, depths, mindx, meandx, dy, S,&
+       radius, rfactor, nlobs_array, ni, nj)
+#if defined (QMPI)
+    use qmpi
+#else
+    use qmpi_fake
+#endif
+    use m_parameters
+    use distribute
+    use mod_measurement
+    use m_obs
+    use m_spherdist
+    use m_random
+    use m_point2nc
+    implicit none
+
+    ! Input/output arguments
+    integer, intent(in) :: nrens
+    real, dimension(ni, nj), intent(in) :: modlon, modlat
+    real, dimension(ni, nj), intent(in) :: depths
+    real, intent(in) :: mindx ! min grid size
+    real, intent(in) :: meandx ! mean grid size
+    real, dimension(nobs), intent(inout) :: dy ! innovations
+    real, dimension(nobs, nrens), intent(inout) :: S ! HA
+    real, intent(in) :: radius ! localisation radius in km
+    real, intent(in) :: rfactor ! obs. variance multiplier for anomalies
+    integer, dimension(ni, nj), intent(out) :: nlobs_array ! # of local obs
+                                                           ! for each grid cell
+    integer, intent(in) :: ni, nj ! horizontal grid size
+
+    real, dimension(nrens, nrens) :: X5tmp
+    integer, dimension(nobs) :: lobs ! indices of local observations
+
+    real, allocatable, dimension(:,:) :: D ! observation perturbations
+    real, allocatable, dimension(:) :: subdy
+    real, allocatable, dimension(:) :: lfactors ! loc. coeffs stored for QC
+    real, allocatable, dimension(:,:) :: subD, subS ! nobs x nrens
+    real, allocatable, dimension(:,:) :: X1 ! nobs x nobs
+    real, allocatable, dimension(:,:) :: G
+    real, allocatable, dimension(:) :: x
+    real :: sqrtm
+    real :: tmp(1)
+
+    integer :: iostatus
+    integer, dimension(nj):: jmap, jmap_check
+#if defined (QMPI)
+    integer, allocatable, dimension(:, :) :: mpibuffer_int
+    real(4), allocatable, dimension(:, :) :: mpibuffer_float1, mpibuffer_float2
+#endif
+
+    integer :: lapack_info
+
+#if defined (QMPI)
+    integer :: p
+#endif
+    integer :: nlobs ! # of local obs
+    integer :: m, i, j, o, jj, iter
+    logical :: testthiscell ! test analysis at a certain cell
+    integer :: irecl
+    integer :: nlobs_max ! maximal number of local obs
+    real :: dist, lfactor
+    type(measurement) :: obs0
+
+    ! dfs calculation
+    real :: dfs
+    real(4) :: dfs_array(ni, nj)
+    ! srf calculation
+    real :: srf
+    real(4) :: srf_array(ni, nj)
+
+    ! "partial" dfs
+    real :: pdfs(nuobs)
+    real(4) :: pdfs_array(ni, nj, nuobs)
+    ! "partial" srf
+    real :: psrf(nuobs)
+    real(4) :: psrf_array(ni, nj, nuobs)
+    ! auxiliary variables for dfs and srf calculation, such as
+    ! nobs for different obs types
+    integer :: plobs(nobs, nuobs)
+    integer :: pnlobs(nuobs)
+    integer :: uo
+
+    if (trim(METHODTAG) == "ENKF") then
+       SCHEME_USED = SCHEME_ENKF
+    elseif (trim(METHODTAG) == "DENKF") then
+       SCHEME_USED = SCHEME_DENKF
+    end if
+
+    if (master) then
+       if (SCHEME_USED == SCHEME_ENKF) then
+          print *, 'using EnKF analysis scheme'
+       elseif (SCHEME_USED == SCHEME_DENKF) then
+          print *, 'using DEnKF analysis scheme'
+       end if
+    end if
+
+    if (LOCRAD > 0.0d0) then
+       if (trim(LOCFUNTAG) == "GASPARI-COHN"&
+            .or. trim(LOCFUNTAG) == "GASPARI_COHN") then
+          LOCFUN_USED = LOCFUN_GASPARI_COHN
+       elseif (trim(LOCFUNTAG) == "STEP") then
+          LOCFUN_USED = LOCFUN_STEP
+       elseif (trim(LOCFUNTAG) == "NONE") then
+          LOCFUN_USED = LOCFUN_NONE
+       end if
+    else
+       LOCFUN_USED = LOCFUN_NONE
+    end if
+
+    if (master) then
+       if (LOCFUN_USED ==  LOCFUN_GASPARI_COHN) then
+          print *, 'using Gaspari-Cohn localisation'
+       elseif (LOCFUN_USED ==  LOCFUN_STEP) then
+          print *, 'using STEP localisation'
+       elseif (LOCFUN_USED ==  LOCFUN_NONE) then
+          print *, 'using NO localisation'
+       end if
+    end if
+
+    sqrtm = sqrt(real(nrens) - 1.0d0)
+    if (SCHEME_USED == SCHEME_ENKF) then
+       allocate(D(nobs, nrens))
+       do o = 1, nobs
+          call randn(nrens, D(o, :))
+          D(o, :) = D(o, :) / (rfactor * sqrtm)
+       end do
+    end if
+    do o = 1, nobs
+       S(o, :) = S(o, :) / (sqrt(obs(o) % var) * sqrtm)
+       dy(o) = dy(o) / (sqrt(obs(o) % var) * sqrtm)
+    end do
+
+    ! Distribute loops across MPI nodes
+    call distribute_iterations(nj)
+
+    ! The binary file tmpX5.uf holds (ni x nj) local ensemble transform
+    ! matrices X5, (nrens x nrens) each. They are used for creating the 
+    ! analysed ensemble in local_analysis(). In TOPAZ3 tmpX5.uf takes about
+    ! 30GB of the disk space.
+    !
+    nX5pad = get_npad_la(nrens * nrens, ni)
+    allocate(X5pad(nX5pad))
+    inquire(iolength = irecl) X5, X5pad
+
+    if (master) then
+       open(17, file = 'tmpX5.uf', form = 'unformatted', access = 'direct', status = 'unknown', recl = irecl)
+       ! get the necessary space on disk, before starting simultaneous writing
+       ! by different nodes
+       write(17, rec = nj) X5
+       close(17)
+    end if
+#if defined (QMPI)
+    call barrier()
+#endif
+    open(17, file = 'tmpX5.uf', form = 'unformatted', access = 'direct',&
+         status = 'old', recl = irecl)
+
+    open(31, file = trim(JMAPFNAME), status = 'old', iostat = iostatus)
+    if (iostatus /= 0) then
+       if (master) then
+          print *, 'WARNING: could not open jmap.txt for reading'
+          print *, '         no re-mapping of grid rows performed'
+       end if
+       do j = 1, nj
+          jmap(j) = j
+       end do
+    else
+       read(31, *, iostat = iostatus) jmap
+       if (iostatus /= 0) then
+          print *, 'ERROR reading jmap.txt'
+          stop
+       end if
+       close(31)
+       jmap_check = 1
+       jmap_check(jmap) = 0
+       if (sum(jmap_check) /= 0) then
+          print *, 'ERROR: non-zero control sum for jmap =', sum(jmap_check)
+          stop
+       end if
+    end if
+
+    ! main cycle (over horizontal grid cells)
+    !
+    dfs_array = 0.0
+    pdfs_array = 0.0
+    srf_array = 0.0
+    psrf_array = 0.0
+    nlobs_array = 0
+    do jj = my_first_iteration, my_last_iteration
+       j = jmap(jj)
+       print *, 'calc_X5(): jj =', jj, 'j =', j
+
+       do i = 1, ni
+          ! data dumping flag
+          testthiscell = p2nc_testthiscell(i, j)
+
+          if (testthiscell) then
+             print *, 'testthiscell: depth(,', i, ',', j, ') =', depths(i, j)
+          end if
+
+          if (depths(i, j) > 0.0d0) then
+             nlobs = 0 ! no upper limit on the number of local observations
+             call get_local_obs(i, j, radius * 1000.0, modlon, modlat,&
+                  mindx, ni, nj, nlobs, lobs)
+             nlobs_array(i, j) = nlobs
+          else
+             nlobs = 0
+          end if
+
+          if (testthiscell) then
+             print *, 'testthiscell: nlobs(,', i, ',', j, ') =', nlobs
+          end if
+
+          if (nlobs == 0) then
+             ! just in case
+             X5(:, :, i) = 0.0
+             X5tmp = 0.0d0
+             do m = 1, nrens
+                X5(m, m, i) = 1.0
+                X5tmp(m, m) = 1.0d0
+             enddo
+             if (testthiscell) then
+                call p2nc_writeobs(i, j, nlobs, nrens, X5tmp, modlon(i, j),&
+                     modlat(i, j), depths(i, j))
+             end if
+             dfs_array(i, j) = 0.0
+             pdfs_array(i, j, :) = 0.0
+             srf_array(i, j) = 0.0
+             psrf_array(i, j, :) = 0.0
+             cycle
+          end if
+
+          if (nlobs < 0) then ! an extra check on the C-Fortran interface
+             print *, 'ERROR: nlobs =', nlobs, ' for i, j =', i, j
+             call stop_mpi()
+          end if
+
+          ! Allocate local arrays
+          if (SCHEME_USED == SCHEME_ENKF) then
+             allocate(subD(nlobs, nrens))
+          end if
+          allocate(subdy(nlobs))
+          allocate(lfactors(nlobs))
+          allocate(subS(nlobs, nrens))
+          ! ( BTW subS1 = subS / sqrt(rfactor) )
+          allocate(G(nrens, nlobs))
+          if (nlobs < nrens) then
+             allocate(X1(nlobs, nlobs))
+          else
+             allocate(X1(nrens, nrens))
+          end if
+
+          if (SCHEME_USED == SCHEME_ENKF) then
+             subD = D(lobs(1 : nlobs), :)
+          end if
+          subS = S(lobs(1 : nlobs), :)
+          subdy = dy(lobs(1 : nlobs))
+
+          ! taper ensemble observation anomalies and innovations
+          !
+          if (LOCFUN_USED /= LOCFUN_NONE) then
+             do o = 1, nlobs
+                obs0 = obs(lobs(o))
+                dist = spherdist(modlon(i, j), modlat(i, j),&
+                     obs0 % lon, obs0 % lat)
+                lfactor = locfun(dist / radius / 1000.0)
+                subS(o, :) = subS(o, :) * lfactor
+                subdy(o) = subdy(o) * lfactor
+                lfactors(o) = lfactor
+                
+                if (SCHEME_USED == SCHEME_ENKF) then
+                   subD(o, :) = subD(o, :) * lfactor
+                end if
+             end do
+          else
+             lfactors = 1
+          end if
+
+          ! first iteration - with rfactor = 1, for the update of the mean
+          ! secons iteration - with the specified rfactorm for the update of
+          ! the anomalies
+          !
+          do iter = 1,2
+             if (iter == 2) then
+                if (rfactor == 1.0d0) then
+                   go to 10
+                end if
+                subS = subS / sqrt(rfactor)
+             end if
+
+             if (nlobs < nrens) then ! use observation space
+                ! Construct matrix (S * S' + I) - to be inverted
+                !
+                X1 = matmul(subS, transpose(subS))
+                do o = 1, nlobs
+                   X1(o, o) = X1(o, o) + 1.0d0
+                end do
+
+                ! Inversion via Cholesky decomposition, done in two stages.
+                !
+                call dpotrf('U', nlobs, X1, nlobs, lapack_info)
+                if (lapack_info /= 0) then
+                   print *, '  ERROR: m_local_analysis(): LAPACK error in dpotrf: errno = '&
+                        , lapack_info, 'i, j =', i, j
+                   call stop_mpi
+                endif
+             
+                call dpotri('U', nlobs, X1, nlobs, lapack_info)
+                if (lapack_info /= 0) then
+                   print *, '  ERROR: m_local_analysis(): LAPACK error in dpotri: errno = '&
+                        , lapack_info, 'i, j =', i, j
+                   call stop_mpi
+                endif
+             
+                ! fill the lower triangular part of (symmetric) X1
+                !
+                do o = 2, nlobs
+                   X1(o, 1 :  o - 1) = X1(1 : o - 1, o)
+                end do
+
+                G = matmul(transpose(subS), X1)
+             else ! nlobs >= nrens:  use ensemble space
+                X1 = matmul(transpose(subS), subS)
+                do m = 1, nrens
+                   X1(m, m) = X1(m, m) + 1.0d0
+                end do
+
+                ! Inversion
+                !
+                call dpotrf('U', nrens, X1, nrens, lapack_info)
+                if (lapack_info /= 0) then
+                   print *, '  ERROR: m_local_analysis(): LAPACK error in dpotrf: errno = '&
+                        , lapack_info, 'i, j =', i, j
+                   call stop_mpi
+                endif
+                call dpotri('U', nrens, X1, nrens, lapack_info)
+                if (lapack_info /= 0) then
+                   print *, '  ERROR: m_local_analysis(): LAPACK error in dpotri: errno = '&
+                        , lapack_info, 'i, j =', i, j
+                   call stop_mpi
+                endif
+             
+                do m = 2, nrens
+                   X1(m, 1 :  m - 1) = X1(1 : m - 1, m)
+                end do
+
+                G = matmul(X1, transpose(subS))
+             end if
+
+             if (iter == 1) then
+                 do m = 1, nrens
+                   X5tmp(m, :) = sum(G(m, :) * subdy(:))
+                end do
+             end if
+
+             10 continue
+
+             ! calculate DFS at iteration 1, SRF at iteration 2
+             !
+             if (iter == 1) then
+                dfs = traceprod(G, subS, nrens, nlobs)
+                dfs_array(i, j) = real(dfs, 4)
+                pnlobs = 0
+                do uo = 1, nuobs
+                   do o = 1, nlobs
+                      if (lobs(o) >= uobs_begin(uo) .and.&
+                           lobs(o) <= uobs_end(uo)) then
+                         pnlobs(uo) = pnlobs(uo) + 1
+                         plobs(pnlobs(uo), uo) = o
+                      end if
+                   end do
+                end do
+                pdfs = 0.0d0
+                psrf = 0.0d0
+                do uo = 1, nuobs
+                   if (pnlobs(uo) > 0) then
+                      pdfs(uo) = traceprod(G(:, plobs(1 : pnlobs(uo), uo)),&
+                           subS(plobs(1 : pnlobs(uo), uo), :), nrens, pnlobs(uo))
+                   end if
+                   pdfs_array(i, j, uo) = real(pdfs(uo), 4)
+                end do
+             else
+                if (dfs /= 0.0d0) then
+                   srf = sqrt(traceprod(subS, transpose(subS), nlobs, nrens)&
+                        / traceprod(G, subS, nrens, nlobs)) - 1.0d0
+                else
+                   srf = 0.0d0
+                end if
+                srf_array(i, j) = real(srf, 4)
+                do uo = 1, nuobs
+                   if (pnlobs(uo) > 0) then
+                      if (pdfs(uo) /= 0.0d0) then
+                         psrf(uo) = sqrt(&
+                              traceprod(subS(plobs(1 : pnlobs(uo), uo), :),&
+                              transpose(subS(plobs(1 : pnlobs(uo), uo), :)),&
+                              pnlobs(uo), nrens) /&
+                              traceprod(G(:, plobs(1 : pnlobs(uo), uo)),&
+                              subS(plobs(1 : pnlobs(uo), uo), :),&
+                              nrens, pnlobs(uo))) - 1.0d0
+                      else
+                         psrf(uo) = 0.0d0
+                      end if
+                   end if
+                   psrf_array(i, j, uo) = real(psrf(uo), 4)
+                end do
+             end if
+          end do ! iter
+
+          if  (SCHEME_USED == SCHEME_ENKF) then
+             X5tmp = X5tmp + matmul(G, subD - subS)
+          elseif (SCHEME_USED == SCHEME_DENKF) then
+             X5tmp = X5tmp - 0.5d0 * matmul(G, subS)
+          end if
+          do m = 1, nrens
+             X5tmp(m, m) = X5tmp(m, m) + 1.0d0
+          enddo
+
+          if (testthiscell) then
+             ! ensemble mean
+             allocate(x(nlobs))
+             do o = 1, nlobs
+                x(o) = obs(lobs(o)) % d - dy(lobs(o)) * sqrtm * sqrt(obs(lobs(o)) % var)
+             end do
+             tmp(1) = rfactor
+             call p2nc_writeobs(i, j, nlobs, nrens, X5tmp, modlon(i, j),&
+                  modlat(i, j), depths(i, j), tmp(1), lobs(1 : nlobs), &
+                  obs(lobs(1 : nlobs)), x, subS, subdy, lfactors)
+             deallocate(x)
+          end if
+
+          ! Put X5tmp into the final X5 matrix - to be written to a file
+          !
+          X5(:, :, i) = real(X5tmp, 4)
+
+          deallocate(subS, subdy, lfactors, X1, G)
+          if  (SCHEME_USED == SCHEME_ENKF) then
+             deallocate(subD)
+          end if
+       end do ! i = 1, ni
+
+       ! Write one "stripe" of the temporary matrix X5 to disk
+       iter = 0
+       do while (.true.)
+          iter = iter + 1
+          write(17, rec = j, iostat = iostatus) X5
+          if (iostatus /= 0) then 
+             print *, 'ERROR: calc_X5(): I/O error at writing X5, iostatus = ',&
+                  iostatus
+             print *, 'ERROR: at model line j =', j, ' counter jj = ', jj, 'iter =', iter
+             if (iter < MAXITER) then
+                cycle
+             else
+                print *, 'ERROR: max number of iterations reached, STOP'
+                stop
+             end if
+          end if
+          read(17, rec = j, iostat = iostatus) X5check
+          if (iostatus /= 0) then 
+             print *, 'ERROR: calc_X5(): I/O error at reading X5, iostatus = ',&
+                  iostatus
+             print *, 'ERROR: at j = ', j, ' jj = ', jj, 'iter =', iter
+             if (iter < MAXITER) then
+                cycle
+             else
+                print *, 'ERROR: max number of iterations reached, STOP'
+                stop
+             end if
+          end if
+          if (abs(maxval(X5 - X5check)) > 1.0e-6) then
+             print *, 'ERROR: calc_X5(): inconsistency between written/read X5'
+             print *, 'ERROR: j = ', j, ' jj = ', jj, 'iter =', iter,&
+                  ' maxval(X5 - X5check) =', maxval(X5 - X5check)
+             if (iter < MAXITER) then
+                cycle
+             else
+                print *, 'ERROR: max number of iterations reached, STOP'
+                stop
+             end if
+          end if
+          exit ! OK
+       end do
+       print *, 'FINISHED j =', j, ' jj =', jj
+    end do ! j = my_first_iteration, my_last_iteration
+
+    close(17) ! X5 file
+
+    if (SCHEME_USED == SCHEME_ENKF) then
+       deallocate(D)
+    end if
+
+#if defined(QMPI)
+    if (.not. master) then
+       ! broadcast nlobs and dfs arrays to master
+       call send(nlobs_array(:, jmap(my_first_iteration : my_last_iteration)), 0, 0)
+       call send(dfs_array(:, jmap(my_first_iteration : my_last_iteration)), 0, 1)
+       call send(srf_array(:, jmap(my_first_iteration : my_last_iteration)), 0, 1)
+       allocate(mpibuffer_float1(ni, my_last_iteration - my_first_iteration + 1))
+       allocate(mpibuffer_float2(ni, my_last_iteration - my_first_iteration + 1))
+       do uo = 1, nuobs
+          mpibuffer_float1 = pdfs_array(:, jmap(my_first_iteration : my_last_iteration), uo)
+          call send(mpibuffer_float1, 0, uo + 1)
+          mpibuffer_float2 = psrf_array(:, jmap(my_first_iteration : my_last_iteration), uo)
+          call send(mpibuffer_float2, 0, uo + 1)
+       end do
+       deallocate(mpibuffer_float1)
+       deallocate(mpibuffer_float2)
+    else
+       ! receive nlobs and dfs arrays
+       do p = 2, qmpi_num_proc
+          !
+          ! PS: Ideally, it would be nice to be able to use a simple code like:
+          !
+          ! call receive(nlobs_array(&
+          !              jmap(first_iteration(p) : last_iteration(p))), p - 1)
+          !
+          ! but this seems not to work, at least with the PGI compiler. 
+          ! Perhaps, this is too much to expect from a call to a C function...
+          ! The good news is that using a temporal array works fine.
+          !
+          allocate(mpibuffer_int(ni, last_iteration(p) - first_iteration(p) + 1))
+          call receive(mpibuffer_int, p - 1, 0)
+          nlobs_array(:, jmap(first_iteration(p) : last_iteration(p))) = mpibuffer_int
+          deallocate(mpibuffer_int)
+          allocate(mpibuffer_float1(ni, last_iteration(p) - first_iteration(p) + 1))
+          call receive(mpibuffer_float1, p - 1, 1)
+          dfs_array(:, jmap(first_iteration(p) : last_iteration(p))) = mpibuffer_float1
+          allocate(mpibuffer_float2(ni, last_iteration(p) - first_iteration(p) + 1))
+          call receive(mpibuffer_float2, p - 1, 1)
+          srf_array(:, jmap(first_iteration(p) : last_iteration(p))) = mpibuffer_float2
+          do uo = 1, nuobs
+             call receive(mpibuffer_float1, p - 1, uo + 1)
+             pdfs_array(:, jmap(first_iteration(p) : last_iteration(p)), uo) = mpibuffer_float1
+             call receive(mpibuffer_float2, p - 1, uo + 1)
+             psrf_array(:, jmap(first_iteration(p) : last_iteration(p)), uo) = mpibuffer_float2
+          end do
+          deallocate(mpibuffer_float1)
+          deallocate(mpibuffer_float2)
+       enddo
+    endif
+    ! broadcast nlobs array
+    call broadcast(nlobs_array)
+#endif
+
+    if (master) then
+       nlobs_max = maxval(nlobs_array)
+       print *, 'maximal # of local obs =', nlobs_max,&
+            ' reached for', count(nlobs_array == nlobs_max), 'grid cells'
+       print *, 'average #(*) of local obs =', sum(nlobs_array(:, 1 : nj)) / real(count(nlobs_array(:, 1 : nj) > 0))
+       print *, '  * over cells with non-zero number of local obs only'
+       print *, 'localisation function of type', LOCFUN_USED, 'has been used'
+       print *, 'analysis conducted in obs space in', count(nlobs_array(:, 1 : nj) > 0 .and. nlobs_array(:, 1 : nj) < nrens),&
+            'cells'
+       print *, 'analysis conducted in ens space in', count(nlobs_array(:, 1 : nj) >= nrens),&
+            'cells'
+       print *, 'maximal DFS =', maxval(dfs_array)
+       print *, 'average(*) DFS =', sum(dfs_array) / real(count(dfs_array > 0))
+       print *, '  * over cells with non-zero number of local obs only'
+       print *, '# of cells with DFS > N / 2 =', count(dfs_array > real(nrens / 2, 4))
+
+       call diag2nc(ni, nj, modlon, modlat, nlobs_array, dfs_array, pdfs_array,&
+            srf_array, psrf_array)
+    end if
+  end subroutine calc_X5
+
+
+  integer function get_npad_la(ni, nj)
+    integer, intent(in) :: ni, nj
+
+    get_npad_la = 4096 - mod(ni * nj, 4096)
+    get_npad_la = mod(get_npad_la, 4096)
+  end function get_npad_la
+
+
+  real function locfun(x)
+    real, intent(in) :: x
+
+    real :: xx, xx2, xx3
+
+    select case(LOCFUN_USED)
+
+    case (LOCFUN_NONE)
+       locfun = 1.0
+    case (LOCFUN_STEP)
+       if (x > 1.0) then
+          locfun = 0.0
+       else
+          locfun = 1.0
+       end if
+    case (LOCFUN_GASPARI_COHN)
+       if (x > 1.0) then
+          locfun = 0.0
+       else
+          xx = x * 2.0
+          xx2 = xx * xx
+          xx3 = xx2 * xx
+          if (xx < 1.0) then
+             locfun = 1.0 + xx2 * (- xx3 / 4.0 + xx2 / 2.0)&
+                  + xx3 * (5.0 / 8.) - xx2 * (5.0 / 3.0)
+          else
+             locfun = xx2 * (xx3 / 12.0 - xx2 / 2.0)&
+                  + xx3 * (5.0 / 8.0) + xx2 * (5.0 / 3.0)&
+                  - xx * 5.0 + 4.0 - (2.0 / 3.0) / xx
+          end if
+          locfun = max(locfun, 0.0)
+       end if
+    case default
+       print *, 'ERROR: m_local_analysis.F90: locfun(): LOCFUN_USED =', LOCFUN_USED, 'is unknown'
+       stop
+    end select
+  end function locfun
+
+
+  ! - Sort observations by their distance to the given grid point (i, j).  
+  ! - Identify observations within a given radius `rmax'.
+  ! - Select `nlobs' nearest observations; update `nlobs' if there are not
+  ! enough observations within the radius.
+  !
+  ! Note that because all observations are parsed for each 2D grid point, this
+  ! subroutine may become a bottleneck if the total number of observations
+  ! grows substantially from the current point... If this happens, we may
+  ! consider putting all observations in a K-D tree like in Szyonykh et. al
+  ! (2008), A local ensemble transform Kalman filter data assimilation system
+  ! for the NCEP global model (2008). Tellus 60A, 113-130.
+  !
+  subroutine get_local_obs(i, j, rmax, modlon, modlat, mindx,&
+       ni, nj, nlobs, lobs)
+    use mod_measurement
+    use m_obs
+    use m_spherdist
+
+    implicit none
+    integer, intent(in) :: i, j
+    real, intent(in) :: rmax ! maximal allowed distance
+    real, intent(in) :: modlon(ni, nj)
+    real, intent(in) :: modlat(ni, nj)
+    real, intent(in) :: mindx
+    integer, intent(in) :: ni, nj
+    integer, intent(inout) :: nlobs ! input : max allowed # of local obs
+                                   ! output: actual # of local obs for this
+                                   !         point
+    integer, intent(out) :: lobs(nobs) ! indices of local observations
+
+    integer :: ngood
+    integer :: sorted(nobs)
+    real :: dist(nobs)
+    integer :: o
+    real :: rmax2
+
+    lobs = 0
+    ngood = 0
+    rmax2 = (rmax / mindx) ** 2
+    do o = 1, nobs
+       if ((obs(o) % ipiv - i) ** 2 + (obs(o) % jpiv - j) ** 2 > rmax2) then
+          cycle
+       end if
+
+       dist(o) = spherdist(obs(o) % lon, obs(o) % lat, modlon(i, j), modlat(i, j))
+       if (dist(o) <= rmax) then
+          ngood = ngood + 1
+          lobs(ngood) = o
+       end if
+    end do
+
+    if (nlobs <= 0 .or. nlobs >= ngood) then
+       !
+       ! use all observations within localisation support radius
+       !
+       nlobs = ngood
+    else
+       !
+       ! use `nlobs' closest observations
+       !
+       call order(dble(nobs), dist, dble(ngood), lobs, sorted)
+       lobs(1 : nlobs) = sorted(1 : nlobs)
+    end if
+  end subroutine get_local_obs
+
+
+  ! This subroutine writes (1) the number of local observations, (2)
+  ! the number of degrees of freedom of signal (DFS), and (3) spread reduction
+  ! factor (SRF) to file "enkf_diag.nc"
+  !
+  subroutine diag2nc(ni, nj, lon, lat, nlobs_array, dfs_array, pdfs_array, &
+       srf_array, psrf_array)
+    use mod_measurement
+    use m_obs
+    use nfw_mod
+    implicit none
+
+    integer, intent(in) :: ni
+    integer, intent(in) :: nj
+    real, intent(in) :: lon(ni, nj)
+    real, intent(in) :: lat(ni, nj)
+    integer, intent(in) :: nlobs_array(ni, nj)
+    real(4), intent(in) :: dfs_array(ni, nj)
+    real(4), intent(in) :: pdfs_array(ni, nj, nuobs)
+    real(4), intent(in) :: srf_array(ni, nj)
+    real(4), intent(in) :: psrf_array(ni, nj, nuobs)
+
+    character(STRLEN) :: fname
+    character(STRLEN) :: varname
+    integer :: ncid
+    integer :: dimids(2)
+    integer :: lon_id, lat_id, nlobs_id, dfs_id, pdfs_id(nuobs), srf_id,&
+         psrf_id(nuobs)
+    integer :: uo
+
+    fname = 'enkf_diag.nc'
+    call nfw_create(fname, nf_clobber, ncid)
+    
+    call nfw_def_dim(fname, ncid, 'i', ni, dimids(1))
+    call nfw_def_dim(fname, ncid, 'j', nj, dimids(2))
+    call nfw_def_var(fname, ncid, 'lon', nf_float, 2, dimids, lon_id)
+    call nfw_def_var(fname, ncid, 'lat', nf_float, 2, dimids, lat_id)
+    call nfw_def_var(fname, ncid, 'nobs', nf_int, 2, dimids, nlobs_id)
+    call nfw_def_var(fname, ncid, 'dfs', nf_float, 2, dimids, dfs_id)
+    do uo = 1, nuobs
+       write(varname, '(a, a)') 'dfs_', trim(unique_obs(uo))
+       call nfw_def_var(fname, ncid, trim(varname), nf_float, 2, dimids, pdfs_id(uo))
+    end do
+    call nfw_def_var(fname, ncid, 'srf', nf_float, 2, dimids, srf_id)
+    do uo = 1, nuobs
+       write(varname, '(a, a)') 'srf_', trim(unique_obs(uo))
+       call nfw_def_var(fname, ncid, trim(varname), nf_float, 2, dimids, psrf_id(uo))
+    end do
+    call nfw_enddef(fname, ncid)
+
+    call nfw_put_var_double(fname, ncid, lon_id, lon)
+    call nfw_put_var_double(fname, ncid, lat_id, lat)
+    call nfw_put_var_int(fname, ncid, nlobs_id, nlobs_array)
+    call nfw_put_var_real(fname, ncid, dfs_id, dfs_array)
+    call nfw_put_var_real(fname, ncid, srf_id, srf_array)
+    do uo = 1, nuobs
+       call nfw_put_var_real(fname, ncid, pdfs_id(uo), pdfs_array(:, :, uo))
+       call nfw_put_var_real(fname, ncid, psrf_id(uo), psrf_array(:, :, uo))
+    end do
+    call nfw_close(fname, ncid)
+  end subroutine diag2nc
+
+
+  ! Calculates the trace of a product of two matrices. (Does not calculate
+  ! the off-diagonal elements in the process.)
+  !
+  real function traceprod(A, B, n, m)
+    real, intent(in) :: A(n, m), B(m, n)
+    integer, intent(in) :: n, m
+
+    integer :: i
+
+    traceprod = 0.0d0
+    do i = 1, n
+       traceprod = traceprod + sum(A(i, :) * B(:, i))
+    end do
+  end function traceprod
+
+end module m_local_analysis

EnKF-MPI-TOPAZ/m_obs.F90

@@ -0,0 +1,332 @@
+! File:          m_obs.F90
+!
+! Created:       6 Feb 2008
+!
+! Last modified: 21 Feb 2008
+!
+! Author:        Pavel Sakov*
+!                NERSC
+!
+! Purpose:       Generic code to deal with observations.
+!
+! Description:   This module contains the following functions and subroutines:
+!                  - obs_setobs
+!                      reads the observations into allocatable array obs(nobs)
+!                      of type(measurement)
+!                  - obs_prepareobs
+!                      conducts state-dependent pre-processing of observations
+!                  - obs_prepareuobs
+!                      conducts state-dependent pre-processing of observations
+!                      of a given type
+!                It also contains the following data:
+!                  - obs
+!                      allocatable array of type(measurement)
+!                  - nobs
+!                      number of observations (may differ from the size of the
+!                      array)
+!
+!                * This file contains some modified code of unknown origin
+!                  from EnKF package. In particular, the code here supersedes
+!                  the code from:
+!                    m_get_nrobs_d.F90
+!                    m_get_obs_d.F90
+!
+! Modifications:
+!                09/11/2012 Geir Arne Waagbo:
+!                -- Added support for OSISAF ice drift obs
+!                29/07/2010 PS:
+!                -- modified obs_QC(). The maximal increment now does not go to
+!                   0 as the innovation increases, but rather is limited by 
+!                   KMAX * sigma_ens
+!                29/06/2010 PS:
+!                 -- added obs_QC()
+!                26/02/2008 PS: 
+!                 -- put "obs" and "nobs" as public data in this module
+
+module m_obs
+#if defined (QMPI)
+    use qmpi
+#else
+    use qmpi_fake
+#endif
+  use mod_measurement
+  use m_uobs
+  use m_insitu
+  implicit none
+
+  !
+  ! public stuff
+  !
+
+  integer, public :: nobs = -1
+  type(measurement), allocatable, dimension(:), public :: obs
+
+  public obs_readobs
+  public obs_prepareobs
+  public obs_QC
+
+  !
+  ! private stuff
+  !
+
+  private obs_testrange
+
+  integer, parameter, private :: STRLEN = 512
+
+  real, parameter, private :: TEM_MIN = -2.0d0
+  real, parameter, private :: TEM_MAX = 50.0d0
+  real, parameter, private :: SAL_MIN = 2.0d0
+  real, parameter, private :: SAL_MAX = 40.0d0
+  real, parameter, private :: SSH_MIN = -3.0d0
+  real, parameter, private :: SSH_MAX = 3.0d0
+  real, parameter, private :: ICEC_MIN = 0.0d0
+  real, parameter, private :: ICEC_MAX = 0.999d0        ! [FM] Changed from 0.996 to 0.999
+  real, parameter, private :: UVICE_MIN = -100.0
+  real, parameter, private :: UVICE_MAX = 100.0
+
+  private obs_prepareuobs, obs_realloc
+
+contains
+
+  ! Obtain observations to be used for assimilation from the file
+  ! "observation.uf". Store the number of observations in "nobs" and the data
+  ! in the array "obs".
+  !
+  subroutine obs_readobs
+    use m_parameters
+
+    logical :: exists = .false.
+    type(measurement) :: record
+    integer :: rsize
+    integer :: ios
+    integer :: o
+
+    if (nobs >= 0) then
+       return
+    end if
+
+    inquire(file = 'observations.uf', exist = exists)
+    if (.not. exists) then
+       if (master) then
+          print *, 'ERROR: obs_getnobs(): file "observations.uf" does not exist'
+       end if
+       stop
+    end if
+    inquire(iolength = rsize) record
+    open(10, file = 'observations.uf', form = 'unformatted',&
+         access = 'direct', recl = rsize, status = 'old')
+
+    ! I guess there is no other way to work out the length other than read the
+    ! file in fortran - PS
+    !
+    o = 1
+    do while (.true.)
+       read(10, rec = o, iostat = ios) record
+       if (ios /= 0) then
+          nobs = o - 1
+          exit
+       end if
+       o = o + 1
+    enddo
+
+    allocate(obs(nobs))
+
+    ! PS - there were problem with using rewind(): g95 reported:
+    ! "Cannot REWIND a file opened for DIRECT access". Therefore reopen.
+    !
+    close(10)
+    open(10, file = 'observations.uf', form = 'unformatted',&
+         access = 'direct', recl = rsize, status = 'old')
+    do o = 1, nobs
+       read(10, rec = o) obs(o)
+       call ucase(obs(o) % id)
+    enddo
+    close(10)
+
+    if (RFACTOR1 /= 1.0d0) then
+       do o = 1, nobs
+          obs(o) % var = obs(o) % var * RFACTOR1
+       end do
+    end if
+
+   call  uobs_get(obs % id, nobs, master)
+   
+   call obs_testrange
+  end subroutine obs_readobs
+
+
+  subroutine obs_testrange
+    integer :: o, uo, nbad
+    real :: dmin, dmax
+       
+    if (master) then
+       print '(a)', ' EnKF: testing range for each type of obs '
+    end if
+    do uo = 1, nuobs
+       if (trim(unique_obs(uo)) == 'SST' .or. trim(unique_obs(uo)) == 'TEM'&
+            .or. trim(unique_obs(uo)) == 'GTEM') then
+          dmin = TEM_MIN
+          dmax = TEM_MAX
+       elseif (trim(unique_obs(uo)) == 'SAL'&
+            .or. trim(unique_obs(uo)) == 'GSAL') then
+          dmin = SAL_MIN
+          dmax = SAL_MAX
+       elseif (trim(unique_obs(uo)) == 'SLA'&
+            .or. trim(unique_obs(uo)) == 'TSLA'&
+            .or. trim(unique_obs(uo)) == 'SSH') then
+          dmin = SSH_MIN
+          dmax = SSH_MAX
+       elseif (trim(unique_obs(uo)) == 'ICEC') then
+          dmin = ICEC_MIN
+          dmax = ICEC_MAX
+       elseif (trim(unique_obs(uo)) == 'AT_I') then     ! [FM] Added as we assimilate total ice conc. (opposed to indiv. category
+          dmin = ICEC_MIN
+          dmax = ICEC_MAX
+       elseif (trim(unique_obs(uo)) == 'V_ICE'&
+            .or. trim(unique_obs(uo)) == 'U_ICE') then
+          dmin = UVICE_MIN
+          dmax = UVICE_MAX
+       elseif (trim(unique_obs(uo)) == 'U2D_I'&         ! [FM] OSISAF 2-day sea ice drift converted to m/s and interpolated onto ORCA
+            .OR. trim(unique_obs(uo)) == 'V2D_I') THEN
+          dmin = UVICE_MIN
+          dmax = UVICE_MAX
+       elseif ((index(trim(unique_obs(uo)),'DX') .gt. 0) &
+            .or. (index(trim(unique_obs(uo)),'DY') .gt. 0)) then
+          ! The type can be DX1,DX2,..,DX5,DY1,..DY5
+          dmin = UVICE_MIN
+          dmax = UVICE_MAX
+       else
+          dmin = -1.0d6
+          dmax = 1.0d6
+          print *, 'ERROR: obs_testrange(): "', trim(unique_obs(uo)), '": unknown type'
+          stop
+       end if
+       
+       nbad = 0
+       do o = uobs_begin(uo), uobs_end(uo)
+          if (obs(o) % status .and.&
+               (obs(o) % d < dmin .or. obs(o) % d > dmax)) then
+             obs(o) % status = .false.
+             nbad = nbad + 1
+          end if
+       end do
+       if (master) then
+          print '(a, a, a, i6, a)', '   ', trim(unique_obs(uo)), ': ', nbad, ' outliers'
+       end if
+    end do
+
+    if (master) then
+       print *
+    end if
+  end subroutine obs_testrange
+
+
+  ! Prepare observations before allocating matrices S, D, and A in EnKF().
+  ! This invloves mainly thinning, superobing, or sorting.
+  !
+  ! Note that generically this processing can not be completely outsourced
+  ! to the preprocessing stage, at least for in-situ data, because its thinning
+  ! involves reading ensemble members for layer depth information.
+  !
+  subroutine obs_prepareobs()
+    implicit none
+
+    integer :: iuobs
+
+    if (master) then
+       print '(a)', ' EnKF: preparing observations'
+    end if
+    do iuobs = 1, nuobs
+       call obs_prepareuobs(trim(unique_obs(iuobs)))
+    end do
+
+   ! calculate again the number of observation of each type (that could change
+   ! in prepare_obs)
+    call  uobs_get(obs % id, nobs, master)
+  end subroutine obs_prepareobs
+
+
+  ! Prepare (thin, superob) observations of type "obstag".
+  !
+  subroutine obs_prepareuobs(obstag)
+    character(*), intent(in) :: obstag
+
+    character(STRLEN) :: fname
+
+    if (trim(obstag) == 'SAL' .or. trim(obstag) == 'TEM' .or.&
+         trim(obstag) == 'GSAL' .or. trim(obstag) == 'GTEM') then
+       call insitu_prepareobs(trim(obstag), nobs, obs)
+       if (master) then
+          write(fname, '(a, ".nc")') trim(obstag)
+          print *, 'Writing "', trim(obstag), '" obs to be assimilated to "',&
+               trim(fname), '"'
+          call insitu_writeprofiles(fname, trim(obstag), nobs, obs);
+       end if
+    else
+       ! do nothing for obs of other types for now
+    end if
+    call obs_realloc
+  end subroutine obs_prepareuobs
+
+  
+  subroutine obs_realloc()
+    type(measurement), allocatable :: newobs(:)
+    
+    if (nobs < 0 .or. nobs == size(obs)) then
+       return
+    end if
+
+    allocate(newobs(nobs))
+    newobs = obs(1 : nobs)
+    deallocate(obs)
+    allocate(obs(nobs))
+    obs = newobs
+    deallocate(newobs)
+  end subroutine obs_realloc
+
+
+  subroutine obs_QC(m, S)
+    use m_parameters
+    implicit none
+
+    integer :: m
+    real :: S(nobs, m)
+
+    integer :: nmodified(nuobs)
+    real :: so(m), smean, svar
+    integer :: o, uo
+    real :: ovar, inn, newovar
+
+    if (master) then
+       print *, 'Starting generic observation QC'
+    end if
+
+    nmodified = 0
+
+    do uo = 1, nuobs
+       do o = uobs_begin(uo), uobs_end(uo)
+          so = S(o, :);
+          smean = sum(so) / m ! must be 0...
+          svar = sum((so - smean) ** 2) / real(m - 1)
+          ovar = obs(o) % var
+
+          inn = obs(o) % d - smean
+          obs(o) % var = sqrt((svar + ovar) ** 2 +&
+               svar * (inn / KFACTOR) ** 2) - svar
+
+          if (svar > 0 .and. obs(o) % var / ovar > 2.0d0) then
+             nmodified(uo) = nmodified(uo) + 1
+          end if
+       end do
+    end do
+
+    if (master) then
+       do uo = 1, nuobs
+          print *, '  ', trim(unique_obs(uo)), ':'
+          print *, '    # of observations:', uobs_end(uo) - uobs_begin(uo) + 1
+          print *, '    (of them) substantially modified:', nmodified(uo)
+       end do
+    end if
+  end subroutine obs_QC
+
+end module m_obs

EnKF-MPI-TOPAZ/m_oldtonew.F90

@@ -0,0 +1,48 @@
+module m_oldtonew
+  use m_confmap
+  implicit none
+
+contains
+
+  ! this routine performes a conformal mapping of the old to the new
+  ! coordinate system
+  !
+  subroutine oldtonew(lat_o, lon_o, lat_n, lon_n)
+    real(8), intent(in) :: lat_o, lon_o
+    real(8), intent(out) :: lat_n, lon_n
+
+    real :: theta, phi, psi, mu
+    complex :: z, w
+
+    if (.not. confmap_initialised) then
+       print *, 'ERROR: oldtonew(): confmap not initialised'
+       stop
+    end if
+
+    ! transform to spherical coordinates
+    !
+    theta = mod(lon_o * rad + 3.0 * pi_1, 2.0 * pi_1) - pi_1
+    phi = pi_2 - lat_o * rad
+
+    ! transform to the new coordinate system
+    !
+    if (abs(phi - pi_1) < epsil) then
+       mu = mu_s
+       psi = psi_s
+    elseif (abs(phi - phi_b) < epsil .and. abs(theta - theta_b) < epsil) then
+       mu = 0.0
+       psi = pi_1
+    else
+       z = tan(0.5 * phi) * exp(imagone * theta)
+       w = (z - ac) * cmnb / ((z - bc) * cmna)
+       mu = atan2(aimag(w), real(w))
+       psi = 2.0 * atan(abs(w))
+    endif
+
+    ! transform to lat/lon coordinates
+    !
+    lat_n = (pi_2 - psi) * deg
+    lon_n = mu * deg
+  end subroutine oldtonew
+
+end module m_oldtonew

EnKF-MPI-TOPAZ/m_parameters.F90

@@ -0,0 +1,268 @@
+! File:          m_parameters.F90
+!
+! Created:       6 August 2010
+!
+! Last modified: 6/8/2010
+!
+! Author:        Pavel Sakov
+!                NERSC
+!
+! Purpose:       Provide a simpl nml list-based parameter input into EnKF.
+!
+! Description:   Provides code for reading parameters from a specified 
+!                parameter file.
+!
+! Modifications: none
+
+module m_parameters
+#if defined(QMPI)
+  use qmpi
+#else
+  use qmpi_fake
+#endif
+  implicit none
+
+  integer, parameter, private :: STRLEN = 512
+  integer, parameter, private :: FID = 101
+
+  character(STRLEN), public :: PRMFNAME = "NONE"
+
+  integer, public :: ENSSIZE = 0
+  namelist /ensemble/ ENSSIZE
+
+  character(STRLEN), public :: METHODTAG = "NONE"
+  namelist /method/ METHODTAG
+
+  real, public :: LOCRAD = 0.0d0
+  character(STRLEN), public :: LOCFUNTAG = "GASPARI-COHN"
+  namelist /localisation/ LOCRAD, LOCFUNTAG
+
+  real, public :: INFL = 1.0d0
+  real, public :: RFACTOR1 = 1.0d0
+  real, public :: RFACTOR2 = 1.0d0
+  real, public :: KFACTOR = 2.0d0
+  namelist /moderation/ INFL, RFACTOR1, RFACTOR2, KFACTOR
+
+  character(STRLEN), public :: JMAPFNAME = "NONE"
+  character(STRLEN), public :: POINTFNAME = "NONE"
+  character(STRLEN), public :: MEANSSHFNAME = "NONE"
+  namelist /files/ JMAPFNAME, POINTFNAME, MEANSSHFNAME
+
+  integer, parameter, private :: NPRMESTMAX = 10
+  integer :: nprmest = 0
+  character(STRLEN), dimension(NPRMESTMAX), public :: PRMESTNAME
+  real, dimension(NPRMESTMAX), public :: PRMINFL
+  namelist /prmest/ PRMESTNAME, PRMINFL
+
+  public prm_read, prm_describe, prm_print, prm_getinfl, prm_prmestexists, ucase
+
+contains
+
+  subroutine prm_read
+    integer :: ios, i
+
+    call getarg(1, PRMFNAME)
+
+    if (master) then
+       print *, 'EnKF: reading parameters from "', trim(PRMFNAME), '":'
+    end if
+
+    open(unit = FID, file = trim(PRMFNAME), form = "formatted",&
+         status = "old", iostat = ios)
+    if (ios /= 0) then
+       if (master) then
+          print *,  'ERROR: could not open "', trim(PRMFNAME), '", iostatus =', ios
+          stop
+       end if
+    end if
+
+    read(unit = FID, nml = method, iostat = ios)
+    if (ios /= 0) then
+       if (master) then
+          print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "method"'
+       end if
+       stop
+    end if
+    rewind(FID)
+
+    read(unit = FID, nml = ensemble, iostat = ios)
+    if (ios /= 0) then
+       if (master) then
+          print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "ensemble"'
+       end if
+       stop
+    end if
+    rewind(FID)
+
+    read(unit = FID, nml = localisation, iostat = ios)
+    if (ios /= 0) then
+       if (master) then
+          print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "localisation"'
+       end if
+       stop
+    end if
+    rewind(FID)
+
+    read(unit = FID, nml = moderation, iostat = ios)
+    if (ios /= 0) then
+       if (master) then
+          print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "moderation"'
+       end if
+       stop
+    end if
+    rewind(FID)
+
+    read(unit = FID, nml = files, iostat = ios)
+    if (ios /= 0) then
+       if (master) then
+          print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "files"'
+       end if
+       stop
+    end if
+    rewind(FID)
+
+    do i = 1, NPRMESTMAX
+       PRMESTNAME(i) =  ""
+    end do
+    read(unit = FID, nml = prmest, iostat = ios)
+    if (ios /= 0) then
+       if (master) then
+          print *, 'ERROR: "', trim(PRMFNAME), '": could not read namelist "prmest"'
+       end if
+       stop
+    end if
+    do i = 1, NPRMESTMAX
+       if (PRMESTNAME(i) ==  "") then
+          nprmest = i - 1
+          exit
+       end if
+    end do
+    rewind(FID)
+
+    close(FID)
+
+    call ucase(METHODTAG)
+    call ucase(LOCFUNTAG)
+  end subroutine prm_read
+
+
+  subroutine prm_describe
+    if (.not. master) then
+       return
+    end if
+
+    print '(a)', ' Example of EnKF parameter file:'
+    print *
+    print '(a)', '&method'
+    print '(a)', '     methodtag    = "DEnKF"'
+    print '(a)', '/'
+    print '(a)', '&ensemble'
+    print '(a)', '     enssize      = 0'
+    print '(a)', '/'
+    print '(a)', '&localisation'
+    print '(a)', '     locfuntag    = "Gaspari-Cohn"'
+    print '(a)', '     locrad       = 300.0'
+    print '(a)', '/'
+    print '(a)', '&moderation'
+    print '(a)', '     infl         = 1.01 (<number>)'
+    print '(a)', '     rfactor1     = 1.0 (<number>)'
+    print '(a)', '     rfactor2     = 2.0 (<number>)'
+    print '(a)', '     kfactor      = 2.0 (<number>)'
+    print '(a)', '/'
+    print '(a)', '&files'
+    print '(a)', '     jmapfname    = "jmap.txt" (<file name>)'
+    print '(a)', '     pointfname   = "point2nc.txt" (<file name>)'
+    print '(a)', '     meansshfname = "meanssh.uf" (<file name>)'
+    print *
+    print '(a)', 'Parameter options:'
+    print '(a)', '  method          = "EnKF" | "DEnKF"*'
+    print '(a)', '  enssize         = <number> (0* to use all available states)'
+    print '(a)', '  locfuntag       = "Gaspari-Cohn"* | "Step" | "None"'
+    print '(a)', '  locrad          = <support radius in km>'
+    print '(a)', '  infl            = <multiple, for ensemble anomalies> (* 1.0)'
+    print '(a)', '  rfactor1        = <obs. error variance multiple> (* 1.0)'
+    print '(a)', '  rfactor2        = <additional multiple for updating ens. anomalies> (* 1.0)'
+    print '(a)', '  kfactor         = <max. allowed increment in terms of ensemble spread> (* 2.0)'
+    print '(a)', '  jmapfname*      = <file with j remapping> (* none)'
+    print '(a)', '  pointfname*     = <file with point coordinates> (* none)'
+    print '(a)', '  meansshfname*   = <file with mean SSH> (* none)'
+  end subroutine prm_describe
+
+
+  subroutine prm_print
+    integer :: i
+
+    if (.not. master) then
+       return
+    end if
+
+    print '(a)', ' EnKF parameters:'
+    print '(a)', '   method:'
+    print '(a, a, a)',  '     methodtag   = "', trim(METHODTAG), '"'
+    print '(a)', '   ensemble:'
+    print '(a, i0)',    '     enssize     = ', ENSSIZE
+    print '(a)', '   localisation:'
+    print '(a, f5.0)',  '     locrad      = ', LOCRAD
+    print '(a, a, a)',  '     locfuntag   = "', trim(LOCFUNTAG), '"'
+    print '(a)', '   moderation:'
+    print '(a, f5.3)',  '     infl        = ', INFL
+    print '(a, f3.1)',  '     rfactor1    = ', RFACTOR1
+    print '(a, f3.1)',  '     rfactor2    = ', RFACTOR2
+    print '(a, f3.1)',  '     kfactor     = ', KFACTOR
+    print '(a)', '   files:'
+    print '(a, a, a)', '     jmapfname    = "', trim(JMAPFNAME), '"'
+    print '(a, a, a)', '     pointfname   = "', trim(POINTFNAME), '"'
+    print '(a, a, a)', '     meansshfname = "', trim(MEANSSHFNAME), '"'
+    print '(a, i0, a)', '   prmest: ', nprmest, ' fields'
+    do i = 1, nprmest
+       print '(a, a, a, f5.3)', '     prmestname = "', trim(PRMESTNAME(i)), '", infl = ', PRMINFL(i)
+    end do
+    print *
+  end subroutine prm_print
+
+
+  function prm_getinfl(fldname)
+    real :: prm_getinfl
+    character(*), intent(in) :: fldname
+    integer :: i
+    
+    prm_getinfl = INFL
+    do i = 1, nprmest
+       if (trim(fldname) == PRMESTNAME(i)) then
+          prm_getinfl = PRMINFL(i)
+          print '(a, a, a, f5.3)', ' "', trim(fldname), '": using inflation = ', prm_getinfl
+          return
+       end if
+    end do
+  end function prm_getinfl
+
+
+  function prm_prmestexists(varname)
+    logical :: prm_prmestexists
+    character(*), intent(in) :: varname
+    integer :: i
+    
+    prm_prmestexists = .false.
+    do i = 1, nprmest
+       if (trim(varname) == PRMESTNAME(i)) then
+          prm_prmestexists = .true.
+          return
+       end if
+    end do
+  end function prm_prmestexists
+
+
+  ! Shift a character string to upper case.
+  !
+  subroutine ucase(string)
+    character(*) :: string
+    integer :: i
+
+    do i = 1, len(string)
+       if (string(i:i) >= 'a' .and. string(i:i) <= 'z') then
+          string(i:i) = achar (iachar ( string(i:i) ) - 32)
+       end if
+    end do
+  end subroutine ucase
+
+end module m_parameters

EnKF-MPI-TOPAZ/m_parse_blkdat.F90

@@ -0,0 +1,141 @@
+module m_parse_blkdat
+   private :: blkini, blkinr, blkinvoid
+contains
+
+   
+      subroutine parse_blkdat(cvar,vtype,realvar,intvar,blkfilein,imatch)
+      implicit none
+      character(len=6), intent(in)  :: cvar
+      character(len=*), intent(in)  :: vtype
+      integer,          intent(out) :: intvar
+      real   ,          intent(out) :: realvar
+      character(len=*), intent(in), optional :: blkfilein
+      integer         , intent(in), optional :: imatch
+
+      character(len=80) :: blkfile
+
+      logical :: found,ex
+      integer :: nmatch,imatch2
+
+      if (present(blkfilein)) then
+         blkfile=blkfilein
+      else
+         blkfile='blkdat.input'
+      end if
+      if (present(imatch)) then
+         imatch2=imatch
+      else
+         imatch2=1
+      end if
+
+
+
+      inquire(exist=ex,file=trim(blkfile))
+
+      nmatch=0
+      if (ex) then
+         open(99,file=trim(blkfile),status='old')
+
+
+         ! Skip header
+         read(99,*)
+         read(99,*)
+         read(99,*)
+         read(99,*)
+
+         found=.false.
+
+         do while (.not.found)
+            found = blkinvoid(cvar)
+
+            if (found) then
+               nmatch=nmatch+1
+               !print *,found,nmatch,imatch2
+               found=found.and.nmatch==imatch2
+               !print *,found
+            end if
+
+         end do
+
+         ! if found, read..
+         if (found) then
+            backspace(99)
+            if (trim(vtype)=='integer') then
+               call blkini(intvar,cvar)
+            elseif (trim(vtype)=='real') then
+               call blkinr(realvar,cvar,'(a6," =",f10.4," m")')
+            else
+               print *,'Dont know how to handle variable type '//trim(vtype)
+               stop '(parse_blkdat)'
+            end if
+         else
+            print *,'Cant find varable'
+            stop '(parse_blkdat)'
+         end if
+
+         close(99)
+      else
+         print *,'Cant find '//trim(blkfile) 
+         stop '(parse_blkdat)'
+      end if
+      end subroutine parse_blkdat
+
+
+
+
+      subroutine blkinr(rvar,cvar,cfmt)
+      !use mod_xc  ! HYCOM communication interface
+      implicit none
+      real      rvar
+      character cvar*6,cfmt*(*)
+!     read in one real value
+      character*6 cvarin
+
+      read(99,*) rvar,cvarin
+      write(6,cfmt) cvarin,rvar
+      !call flush(6)
+
+      if     (cvar.ne.cvarin) then
+        write(6,*) 
+        write(6,*) 'error in blkinr - input ',cvarin, &
+                            ' but should be ',cvar
+        write(6,*) 
+        !call flush(6)
+        stop '(blkinr)'
+      endif
+      return
+      end subroutine
+
+      subroutine blkini(ivar,cvar)
+      implicit none
+      integer     ivar
+      character*6 cvar
+!     read in one integer value
+      character*6 cvarin
+ 
+      read(99,*) ivar,cvarin
+ 
+      if     (cvar.ne.cvarin) then
+        write(6,*) 
+        write(6,*) 'error in blkini - input ',cvarin, &
+                            ' but should be ',cvar
+        write(6,*) 
+        !call flush(6)
+        stop '(blkini)'
+      endif
+    end subroutine blkini
+
+
+
+    logical function blkinvoid(cvar)
+      implicit none
+
+      real :: rvar
+      character :: cvar*6
+      character*6 :: cvarin
+
+      read(99,*) rvar, cvarin
+      blkinvoid = trim(cvar) == trim(cvarin)
+    end function blkinvoid
+
+end module m_parse_blkdat

EnKF-MPI-TOPAZ/m_pivotp.F90

@@ -0,0 +1,51 @@
+module m_pivotp
+  use m_confmap
+  implicit none
+
+contains
+
+  ! This subroutine computes the pivot point of each of the observations
+  ! in the temporary array tmpobs of type observation. The pivot point
+  ! is the biggest i and the biggest j, (i,j) is the computation points/
+  ! the grid, that is less than the position of the observation.
+  !
+  subroutine pivotp(lon, lat, ipiv, jpiv)
+   real, intent(in) ::  lon, lat
+   integer, intent(out) :: ipiv, jpiv
+
+   real :: tmptan
+   real :: lontmp
+   
+    if (.not. confmap_initialised) then
+       print *, 'ERROR: oldtonew(): confmap not initialised'
+       stop
+    end if
+
+   ! fix for wrap-around
+   ! Knut: For some exotic grids the wrap-around
+   ! is not needed. By exotic grid I mean Conman,
+   ! where the poles are on the other side of the earth,
+   ! and the eastern limit is actually WEST of the western 
+   ! limit.... (di < 0)
+   !if (lon < wlim) then
+   if (lon < wlim .and. di > 0. ) then
+      lontmp = lon + 360.0
+   else
+      lontmp = lon
+   endif
+
+   ipiv = int((lontmp - wlim) / di) + 1
+
+   if (mercator) then
+      if (abs(lat) < 89.999) then
+         tmptan = tan(0.5 * rad * lat + 0.25 * pi_1)
+         jpiv = int((log(tmptan) - slim * rad) / (rad * dj)) + 1
+      else
+         jpiv= - 999
+      endif
+   else
+      jpiv = int((lat - slim) / dj) + 1
+   endif
+ end subroutine pivotp
+
+end module m_pivotp

EnKF-MPI-TOPAZ/m_point2nc.F90

@@ -0,0 +1,339 @@
+! File:          m_point2nc.F90
+!
+! Created:       6 July 2010
+!
+! Last modified: 6/7/2010
+!
+! Author:        Pavel Sakov
+!                NERSC
+!
+! Purpose:       Output of assimilation related information for selected points
+!                to files in NetCDF format, 1 file per point.
+!
+! Description:   This module reads a list of points from a file "point2nc.txt"
+!                in the working NetCDF directory. It then dumps the 
+!                assimilation related information for these points in NetCDF
+!                format to files named enkf_III,JJJ.nc, where III and JJJ - i
+!                and j grid coordinates.
+!
+! Modifications: PS 4/8/2010 "point2nc.txt" now allows comments etc. E.g. put
+!                            "#" in front of an entry to comment it out.
+
+module m_point2nc
+  use m_parameters
+  implicit none
+
+  integer, private :: FID = 31
+  integer, parameter, private :: STRLEN = 512
+
+  public p2nc_init
+  public p2nc_testthiscell
+  public p2nc_writeobs
+  public p2nc_storeforecast
+  public p2nc_writeforecast
+
+  integer, private :: npoints
+  integer, allocatable, dimension(:), private :: icoords, jcoords
+  real(4), allocatable, dimension(:, :, :) :: forecast
+
+contains
+
+  ! Initialise the point output.
+  !
+  subroutine p2nc_init()
+#if defined (QMPI)
+    use qmpi
+#else
+    use qmpi_fake
+#endif
+
+    character(STRLEN) :: line
+    integer :: iostatus
+    integer :: i, j, n
+
+    npoints = 0
+
+    open(FID, file = trim(POINTFNAME), status = 'old', iostat = iostatus)
+    if (iostatus /= 0) then
+       if (master) then
+          print *, 'WARNING: could not open "', trim(POINTFNAME), '" for reading'
+          print *, '         no point output will be performed'
+       end if
+       return
+    end if
+    
+    do while (.true.)
+       read(FID, '(a)', iostat = iostatus) line
+       if (iostatus == 0) then
+          read(line, *, iostat = iostatus) i, j
+          if (iostatus == 0) then
+             npoints = npoints + 1
+          end if
+       else
+          exit
+       end if
+    end do
+    close(FID)
+
+    if (master) then
+       print '(a, i3, a)', ' p2nc: ', npoints, ' points specified'
+    end if
+
+    allocate(icoords(npoints), jcoords(npoints))
+
+    open(FID, file = trim(POINTFNAME), status = 'old', iostat = iostatus)
+    if (iostatus /= 0) then
+       print *, 'ERROR: point2nc: I/O problem'
+       stop
+    end if
+    
+    n = 0
+    do while (n < npoints)
+       read(FID, '(a)', iostat = iostatus) line
+       if (iostatus == 0) then
+          read(line, *, iostat = iostatus) i, j
+          if (iostatus == 0) then
+             n = n + 1
+             icoords(n) = i
+             jcoords(n) = j
+             if (master) then
+                print '(a, i3, a, i4, a, i4)', '   point', n, ': i =', i, ', j =', j
+             end if
+          end if
+       end if
+    end do
+    close(FID)
+    if (master) then
+       print *
+    end if
+  end subroutine p2nc_init
+
+  
+  ! Test if the output is requested for the point (i, j) 
+  !
+  function p2nc_testthiscell(i, j)
+    logical :: p2nc_testthiscell
+    integer, intent(in) :: i, j
+
+    integer :: p
+
+    p2nc_testthiscell = .false.
+    do p = 1, npoints
+       if (i == icoords(p) .and. j == jcoords(p)) then
+          p2nc_testthiscell = .true.
+          return
+       end if
+    end do
+  end function p2nc_testthiscell
+
+
+  ! Write the assimilation parameters (local observations and the X5 matrices)
+  ! to the point output files.
+  !
+  subroutine p2nc_writeobs(i, j, nlobs, nens, X5, lon, lat, depth, rfactor,&
+       ids, lobs, Hx, S, ss, lfactors)
+    use mod_measurement
+    use m_obs
+    use nfw_mod
+
+    integer, intent(in) :: i, j, nlobs, nens
+    real, intent(in) :: X5(nens, nens)
+    real, intent(in) :: lon(1), lat(1), depth(1)
+    real, intent(in), optional :: rfactor(1)
+    integer, intent(in), optional :: ids(nlobs)
+    type(measurement), intent(in), optional :: lobs(nlobs)
+    real, intent(in), optional :: Hx(nlobs)
+    real, intent(in), optional :: S(nlobs, nens)
+    real, intent(in), optional :: ss(nlobs), lfactors(nlobs)
+
+    character(STRLEN) :: fname
+    character(STRLEN) :: typename
+    integer :: ncid
+    integer :: dids(2)
+    integer :: vid_ids, vid_lon, vid_lat, vid_val, vid_var, vid_hx, vid_s, vid_x5
+    integer :: vid_a1, vid_a2, vid_a3, vid_a4, vid_otype, vid_ss, vid_lfactors
+    integer :: otype(nlobs)
+    integer :: o, ot
+    
+    write(fname, '(a, i0.3, ",", i0.3, ".nc")') 'enkf_', i, j
+    call nfw_create(fname, nf_write, ncid)
+
+    call nfw_def_dim(fname, ncid, 'p', nlobs, dids(2))
+    call nfw_def_dim(fname, ncid, 'm', nens, dids(1))
+    if (nlobs > 0) then
+       call nfw_def_var(fname, ncid, 'obs_ids', nf_int, 1, dids(2), vid_ids)
+       call nfw_def_var(fname, ncid, 'Hx', nf_double, 1, dids(2), vid_hx)
+       call nfw_def_var(fname, ncid, 'lon', nf_double, 1, dids(2), vid_lon)
+       call nfw_def_var(fname, ncid, 'lat', nf_double, 1, dids(2), vid_lat)
+       call nfw_def_var(fname, ncid, 'obs_val', nf_double, 1, dids(2), vid_val)
+       call nfw_def_var(fname, ncid, 'obs_var', nf_double, 1, dids(2), vid_var)
+       call nfw_def_var(fname, ncid, 'a1', nf_double, 1, dids(2), vid_a1)
+       call nfw_def_var(fname, ncid, 'a2', nf_double, 1, dids(2), vid_a2)
+       call nfw_def_var(fname, ncid, 'a3', nf_double, 1, dids(2), vid_a3)
+       call nfw_def_var(fname, ncid, 'a4', nf_double, 1, dids(2), vid_a4)
+       call nfw_def_var(fname, ncid, 'obs_type', nf_int, 1, dids(2), vid_otype)
+       call nfw_def_var(fname, ncid, 'S', nf_double, 2, dids, vid_s)
+       call nfw_def_var(fname, ncid, 's', nf_double, 1, dids(2), vid_ss)
+       call nfw_def_var(fname, ncid, 'lfactors', nf_double, 1, dids(2), vid_lfactors)
+    end if
+    dids(2) = dids(1)
+    call nfw_def_var(fname, ncid, 'X5', nf_double, 2, dids, vid_x5)
+
+    call nfw_put_att_double(fname, ncid, nf_global, 'lon', nf_double, 1, lon)
+    call nfw_put_att_double(fname, ncid, nf_global, 'lat', nf_double, 1, lat)
+    call nfw_put_att_double(fname, ncid, nf_global, 'depth', nf_double, 1, depth)
+    call nfw_put_att_double(fname, ncid, nf_global, 'rfactor', nf_double, 1, rfactor)
+
+    do ot = 1, nuobs
+       write(typename, '(a, i1)') 'obstype', ot
+       call nfw_put_att_text(fname, ncid, nf_global, typename, len_trim(unique_obs(ot)), trim(unique_obs(ot)))
+    end do
+
+    call nfw_enddef(fname, ncid)
+
+    if (nlobs > 0) then
+       call nfw_put_var_double(fname, ncid, vid_hx, Hx)
+       call nfw_put_var_int(fname, ncid, vid_ids, ids)
+       call nfw_put_var_double(fname, ncid, vid_lon, lobs % lon)
+       call nfw_put_var_double(fname, ncid, vid_lat, lobs % lat)
+       call nfw_put_var_double(fname, ncid, vid_val, lobs % d)
+       call nfw_put_var_double(fname, ncid, vid_var, lobs % var)
+       call nfw_put_var_double(fname, ncid, vid_a1, lobs % a1)
+       call nfw_put_var_double(fname, ncid, vid_a2, lobs % a2)
+       call nfw_put_var_double(fname, ncid, vid_a3, lobs % a3)
+       call nfw_put_var_double(fname, ncid, vid_a4, lobs % a4)
+       otype = 0
+       do o = 1, nlobs
+          do ot = 1, nuobs
+             if (trim(lobs(o) % id) == trim(unique_obs(ot))) then
+                otype(o) = ot
+             end if
+          end do
+       end do
+
+       call nfw_put_var_int(fname, ncid, vid_otype, otype)
+       call nfw_put_var_double(fname, ncid, vid_s, transpose(S))
+       call nfw_put_var_double(fname, ncid, vid_ss, ss)
+       call nfw_put_var_double(fname, ncid, vid_lfactors, lfactors)
+    end if
+
+    call nfw_put_var_double(fname, ncid, vid_x5, transpose(X5))
+
+    call nfw_close(fname, ncid)
+  end subroutine p2nc_writeobs
+
+
+  ! Store the values of the forecast field No. `fid' in each output point to
+  ! the variable `forecast'.
+  !
+  subroutine p2nc_storeforecast(ni, nj, nrens, nfields, fid, field)
+    integer, intent(in) :: ni, nj ! size of grid
+    integer, intent(in) :: nrens
+    integer, intent(in) :: nfields
+    integer, intent(in) :: fid
+    real(4), dimension(ni * nj, nrens), intent(in) :: field
+
+    integer :: n
+
+    if (npoints == 0) then
+       return
+    end if
+
+    if (.not. allocated(forecast)) then
+       allocate(forecast(nrens, npoints, nfields))
+    end if
+
+    do n = 1, npoints
+       forecast(:, n, fid) = field((jcoords(n) - 1) * ni + icoords(n), :)
+    end do
+  end subroutine p2nc_storeforecast
+
+
+  ! This procedure consolidates all forecast fields for each output point 
+  ! together in the variable `forecast' on the master node, and then writes
+  ! them to the appropriate NetCDF files.
+  !
+  subroutine p2nc_writeforecast
+#if defined (QMPI)
+    use qmpi
+#else
+    use qmpi_fake
+#endif
+    use distribute
+    use nfw_mod
+    use mod_analysisfields
+    implicit none
+    
+    character(STRLEN) :: fname
+    integer :: p, k, nf
+    character(8) :: varname
+    integer kstart
+    integer ncid, dids(2), varid, nf2
+
+#if defined(QMPI)
+    if (.not. master) then
+       call send(forecast(:, :, my_first_iteration : my_last_iteration), 0, 0)
+       return ! leave writing to master
+    else
+       do p = 2, qmpi_num_proc ! here p is the MPI node ID
+          call receive(forecast(:, :, first_iteration(p) : last_iteration(p)), p - 1, 0)
+       end do
+    end if
+#endif
+
+    ! only master keeps working here
+    !
+    do p = 1, npoints
+       write(fname, '(a, i0.3, ",", i0.3, ".nc")') 'enkf_', icoords(p), jcoords(p)
+       call nfw_open(fname, nf_write, ncid)
+       call nfw_redef(fname, ncid)
+       call nfw_inq_dimid(fname, ncid, 'm', dids(1))
+       call nfw_enddef(fname, ncid)
+    
+       kstart = -1
+       do k = 1, numfields
+          if (kstart == -1) then
+             kstart = k
+             varname = fieldnames(k)
+          end if
+
+          ! check if there are more fields for this variable
+          !
+          if (k < numfields .and. fieldnames(k + 1) == varname) then
+             cycle
+          end if
+
+          ! this is the last field for this variable - write the variable
+          !
+          nf = k - kstart + 1
+
+          call nfw_redef(fname, ncid)
+
+          if (nf == 1) then
+             call nfw_def_var(fname, ncid, trim(varname), nf_float, 1, dids(1), varid)
+          else
+             if (.not. nfw_dim_exists(ncid, 'k')) then
+                call nfw_def_dim(fname, ncid, 'k', nf, dids(2))
+             else
+                call nfw_inq_dimid(fname, ncid, 'k', dids(2))
+                call nfw_inq_dimlen(fname, ncid, dids(2), nf2)
+                if (nf /= nf2) then
+                   print *, 'ERROR: p2nc_writeforecast(): varname = "', trim(varname),&
+                        '", # levels = ', nf, '# levels in "', trim(fname), '" =', nf2
+                   print *, 'ERROR: p2nc_writeforecast(): returning'
+                end if
+             end if
+             call nfw_def_var(fname, ncid, trim(varname), nf_float, 2, dids, varid)
+          end if
+
+          call nfw_enddef(fname, ncid)
+
+          call nfw_put_var_real(fname, ncid, varid, forecast(:, p, kstart : kstart + nf - 1))
+
+          kstart = -1
+       end do
+       call nfw_close(fname, ncid)
+    end do
+  end subroutine p2nc_writeforecast
+
+end module m_point2nc

EnKF-MPI-TOPAZ/m_prep_4_EnKF.F90

@@ -0,0 +1,597 @@
+! File:          m_prep_4_EnKF.F90
+!
+! Created:       ???
+!
+! Last modified: 29/06/2010
+!
+! Purpose:       Calculation of HA ("S")
+!
+! Description:   Calculates HA by going sequentially through each data type.
+!
+! Modifications:
+!                09/11/2012 Geir Arne Waagbo:
+!                  - Added support for OSISAF ice drift obs
+!                29/07/2010 PS:
+!                  - merged insitu_QC() with generic obs_QC(). Moved
+!                    insitu_writeforecast() to the point after QC.
+!                29/06/2010 PS:
+!                  - added generic observation QC: increase the observation
+!                    error when observation and ensemble mean are much too far
+!                    away than expected
+!                Prior history:
+!                  Not documented.
+
+module m_prep_4_EnKF
+
+  integer, parameter, private :: STRLEN = 512
+
+  private read_mean_ssh
+
+contains
+
+  ! This subroutine uses the observation and ensembles from the model
+  ! to prepare the input to the EnKF analysis scheme.
+  ! The output from this routine is used directly in the global analysis
+  ! while the output has to be run through a "filter" to be used in the
+  ! local analysis scheme.
+
+  ! S = HA     (ensemble observation anomalies)
+  ! d = d - Hx (innovations) 
+  !
+  ! S is calculated in two steps:
+  ! 1. S = HE
+  ! 2. S = S - repmat(s, 1, m), 
+  !    where s = mean(S')';
+  ! Note that in reality (with HYCOM) H is different for each member... 
+  ! So that HX must be read "HX" rather than "H * X".
+  !
+  subroutine prep_4_EnKF(nrens, enslist, d, S, depths, meandx, nx, ny, nz)
+#if defined (QMPI)
+    use qmpi, only : master, stop_mpi
+#else
+    use qmpi_fake, only : master, stop_mpi
+#endif
+    use mod_measurement
+    use m_obs
+    use m_Generate_element_Si
+    use m_get_mod_fld
+    use m_read_icemod
+    use m_parameters
+    implicit none
+
+    integer, intent(in) :: nx, ny, nz ! Model size
+    integer, intent(in) :: nrens ! Size of ensemble
+    integer, dimension(:),intent(in) :: enslist ! [CKB,FM] List of existing ens members
+    real, intent(in) :: depths(nx, ny)
+    real, intent(in) :: meandx ! mean grid size
+    real, intent(inout) :: d(nobs)
+    real, intent(inout) :: S(nobs, nrens)
+
+    real :: x(nobs)
+
+    integer :: i, j, m, iens
+    real*4, dimension(nx,ny) :: fldr4
+    real :: readfld(nx, ny), ai1(nx,ny), ai2(nx,ny), ai3(nx,ny), ai4(nx,ny), ai5(nx,ny), uice(nx,ny), vice(nx,ny)
+
+    ! hard-coded for now
+    integer, parameter :: drnx = 152, drny = 132
+    real*4, dimension(drnx, drny) :: modzon, modmer
+    integer, parameter :: drnx_osisaf = 119, drny_osisaf = 177
+    real*4, dimension(drnx_osisaf, drny_osisaf) :: dX, dY
+
+    integer :: reclSLA, ios, reclDRIFT
+    character*3 :: cmem
+    character*2 :: day
+    character*1 :: offset
+
+    logical :: ex
+
+    character(STRLEN) :: fname
+    integer :: iuobs
+
+    ! FANF: For track assim we launch m_Generate_Si for each day (t=1:Wd)
+    ! which fills in S at the approriate indices.
+    ! Wd is is the assimilation cycle (i.e. 7 days)
+    !
+    integer :: Wd, t
+    integer :: tlevel
+    real :: field2(nx, ny), field3(nx, ny) ! auxiliary fields (e.g. mean SSH, 
+                                           ! field bias estimate etc.)
+    integer :: nthisobs, thisobs(nobs)
+
+    if (any(obs(:) % id == 'TSLA ')) then
+       Wd = 6
+    else
+       Wd = 0
+    endif
+
+    ! security check
+    !
+    if (any(obs(:) % id == 'SSH  ') .or. any(obs(:) % id == 'SLA  ')) then
+       if (any(obs(:) % id == 'SLA  ')) then
+          inquire(exist = ex, file = 'model_SLA.uf')
+          if (.not.ex) then
+             if (master) print *,'model_SLA.uf does not exist'
+             call stop_mpi()
+          end if
+       end if
+       if (any(obs(:) % id == 'SSH  ')) then
+          inquire(exist = ex, file = 'model_SSH.uf')
+          if (.not.ex) then
+             if (master) print *,'model_SSH.uf does not exist'
+             call stop_mpi()
+          end if
+       end if
+    end if
+
+    ! construct S=HA
+    !
+    do iuobs = 1, nuobs
+       if (master) then
+          print *, 'prep_4_EnKF: now preparing "', trim(unique_obs(iuobs)), '" observations'
+       end if
+
+       if (trim(unique_obs(iuobs)) == 'ICEC') then
+          do iens = 1, nrens
+             write(cmem,'(i3.3)') iens
+             tlevel = 1
+             call get_mod_fld_new(trim('forecast'//cmem), readfld, iens,&
+                  'icec', 0, tlevel, nx, ny)
+             if (tlevel == -1) then
+                if (master) then
+                   print *, 'ERROR: get_mod_fld_new(): failed for "icec"'
+                end if
+                stop
+             end if
+             call Generate_element_Si(S(:, iens), unique_obs(iuobs),&
+                  readfld, depths, nx, ny, nz, 0) 
+          end do
+
+       ! [FM, May 2013: for LIM3 sea ice model]
+       elseif (trim(unique_obs(iuobs)) == 'AT_I') then
+          do iens = 1, nrens
+             write(cmem,'(i3.3)') iens
+             tlevel = 1
+             call io_mod_fld(ai1,iens,enslist, &
+                 'a_i_htc1', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(ai2,iens,enslist, &
+                 'a_i_htc2', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(ai3,iens,enslist, &
+                 'a_i_htc3', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(ai4,iens,enslist, &
+                 'a_i_htc4', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(ai5,iens,enslist, &
+                 'a_i_htc5', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             if (tlevel == -1) then
+                if (master) then
+                   print *, 'ERROR: io_mod_fld_new(): failed for "at_i"'
+                end if
+                stop
+             end if
+             readfld=ai1+ai2+ai3+ai4+ai5
+
+             call Generate_element_Si(S(:, iens), unique_obs(iuobs),&
+                  readfld, depths, nx, ny, nz, 0)
+          end do
+
+       elseif (trim(unique_obs(iuobs)) == 'SST') then
+          do iens = 1, nrens
+             write(cmem,'(i3.3)') iens
+             tlevel = 1
+             call get_mod_fld_new(trim('forecast'//cmem), readfld, iens,&
+                  'temp', 1, tlevel, nx, ny)
+             if (tlevel == -1) then
+                if (master) then
+                   print *, 'ERROR: get_mod_fld_new(): failed for "SST"'
+                end if
+                stop
+             end if
+
+             if (prm_prmestexists('sstb')) then
+                tlevel = 1
+                call get_mod_fld_new(trim('forecast'//cmem), field2, iens,&
+                     'sstb', 0, tlevel, nx, ny)
+                if (tlevel == -1) then
+                   if (master) then
+                      print *, 'ERROR: get_mod_fld_new(): failed for "sstb"'
+                   end if
+                   stop
+                end if
+                readfld = readfld - field2
+             end if
+
+             call Generate_element_Si(S(:, iens), unique_obs(iuobs),&
+                  readfld, depths, nx, ny, nz, 0) 
+          end do
+
+       elseif (trim(unique_obs(iuobs)) == 'SLA' .or.&
+            trim(unique_obs(iuobs)) == 'TSLA') then
+
+          if (trim(unique_obs(iuobs)) == 'TSLA') then
+             call read_mean_ssh(field2, nx, ny)
+          end if
+          
+          inquire(iolength=reclSLA) fldr4
+
+          ! FANF loop over each day of the week
+          do t = 0, Wd 
+             if (trim(unique_obs(iuobs)) == 'TSLA') then
+                write(day,'(i2.2)') t 
+                fname = trim('model_TSSH_'//day//'.uf')
+             else
+                fname = 'model_SLA.uf'
+             endif
+             if (master) then
+                print *, 'TSLA, day', t, ': nobs = ',&
+                     count(obs(uobs_begin(iuobs) : uobs_end(iuobs)) % date == t)
+             end if
+             do iens = 1, nrens
+                open(10, file = trim(fname), access = 'direct',&
+                     status = 'old', recl = reclSLA, action = 'read')
+                read(10, rec = iens, iostat = ios) fldr4
+                if (ios /= 0) then
+                   if (master) print *, 'Error reading ', trim(fname), ', member #', iens
+                   call stop_mpi()
+                end if
+                close(10)
+                readfld = fldr4
+                
+                if (prm_prmestexists('msshb')) then
+                   write(cmem,'(i3.3)') iens
+                   tlevel = 1
+                   call get_mod_fld_new(trim('forecast'//cmem), field3, iens,&
+                        'msshb', 0, tlevel, nx, ny)
+                   if (tlevel == -1) then
+                      if (master) then
+                         print *, 'ERROR: get_mod_fld_new(): failed for "msshb"'
+                      end if
+                      stop
+                   end if
+                   readfld = readfld - field3 ! mean SSH bias for this member
+                end if
+
+                if (trim(unique_obs(iuobs)) == 'TSLA') then
+                   readfld = readfld - field2 ! mean SSH
+                end if
+                
+                call Generate_element_Si(S(:, iens), unique_obs(iuobs),&
+                     readfld, depths, nx, ny, nz, t)
+             end do
+             if (master) then
+                print *, 'forming S, day', t
+                print *, '  # of non-zero ens observations = ', count(S /= 0.0)
+                print *, '  # of zero ens observations = ', count(S == 0.0)
+                print *, '  # of non-zero observations for member 1 = ', count(S(:, 1) /= 0.0)
+             end if
+          end do
+
+       elseif (trim(unique_obs(iuobs)) == 'SAL' .or.&
+            trim(unique_obs(iuobs)) == 'TEM' .or.&
+            trim(unique_obs(iuobs)) == 'GSAL' .or.&
+            trim(unique_obs(iuobs)) == 'GTEM') then
+
+          if (master) then
+             print *, '  Interpolating ensemble vectors to the locations of "',&
+                  trim(unique_obs(iuobs)), '" observations'
+          end if
+          !
+          ! for each ensemble member process all profiles "in parallel",
+          ! reading the fields layer by layer
+          !
+          do iens = 1, nrens
+             call get_S(S(:, iens), trim(unique_obs(iuobs)), nobs, obs, iens)
+          end do
+          if (master) then
+             print *, '  Interpolation completed'
+          end if
+          
+       elseif ((trim(unique_obs(iuobs)) == 'U_ICE') .or. trim(unique_obs(iuobs)) == 'V_ICE') then
+          do iens = 1, nrens
+             ! [FM]  Read the file
+             !inquire(iolength=reclDRIFT) modzon, modmer
+             !open(10, file = 'model_ICEDRIFT.uf', access = 'direct',&
+             !     status = 'old', recl = reclDRIFT, action = 'read')
+             !read(10, rec = iens, iostat = ios) modzon, modmer
+             !close(10)
+             !if (ios /= 0) then
+             !   if (master) then
+             !      print *,'ERROR: could not read ensemble ice drift for member ', iens
+             !   end if
+             !   call stop_mpi()
+             !end if
+   
+             call io_mod_fld(uice,iens,enslist, &
+                 'u_ice', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vice,iens,enslist, &
+                 'v_ice', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             do m = 1, nobs
+                i = obs(m) % i_orig_grid
+                j = obs(m) % j_orig_grid
+                if (trim(obs(m) % id) == 'U_ICE') then
+                   S(m, iens) = uice(i, j) 
+                elseif (trim(obs(m) % id) == 'V_ICE') then
+                   S(m, iens) = vice(i, j) 
+                end if
+             end do
+          end do
+       
+       elseif ((trim(unique_obs(iuobs)) == 'U2D_I') .OR. trim(unique_obs(iuobs)) == 'V2D_I' ) THEN
+         ! ADDED BY FM FRANCOIS MASSONNET. u_ice_2d or v_ice_2d is the sea ice u or v-velocity
+         ! obtained as follows:
+         ! 1) Rotate OSISAF Low resolution 2-day sea ice drift in a {east,north}
+         ! reference frame
+         ! 2) Interpolate to the ORCA grid
+         ! 3) Rotate to align with the ORCA grid
+         ! 4) Multiply by 1000 and divide by 2*86400 to convert the 2-day
+         ! displacement from km to m/s
+         DO iens=1,nrens
+                CALL read_icemod(uice,iens,enslist,'iicevelu',nx,ny)
+                CALL read_icemod(vice,iens,enslist,'iicevelv',nx,ny)
+                DO m = 1, nobs
+                   i = obs(m) % i_orig_grid
+                   j = obs(m) % j_orig_grid 
+                   
+                   IF (trim(obs(m) % id) == 'U2D_I') THEN
+                      S(m,iens) = uice(i,j) 
+                   ELSEIF (trim(obs(m) % id) == 'V2D_I') THEN
+                      S(m,iens) = vice(i,j)
+                   END IF
+                END DO ! nobs
+         END DO ! iens
+     
+       elseif ((index(unique_obs(iuobs),'DX') > 0 ) .or. (index(unique_obs(iuobs),'DY') > 0)) then
+          ! OSISAF Ice drift observations (d-2-offset -> d-offset)
+          !print *, 'Ice drift observation type: ', unique_obs(iuobs)
+          offset = unique_obs(iuobs)(3:3)
+          ! Use offset (1,2,3,4 or 5) to open correct model drift file
+          inquire(iolength=reclDRIFT) dX, dY
+          open(10, file = 'model_ICEDRIFT_OSISAF'//offset//'.uf', access = 'direct',&
+               status = 'old', recl = reclDRIFT, action = 'read')
+          do iens = 1, nrens
+             read(10, rec = iens, iostat = ios) dX, dY
+             if (ios /= 0) then
+                if (master) then
+                   print *,'ERROR: could not read ensemble ice drift for member ', iens
+                end if
+                call stop_mpi()
+             end if
+
+             do m = 1, nobs
+                i = obs(m) % i_orig_grid
+                j = obs(m) % j_orig_grid
+                if (index(obs(m)%id,'DX') > 0) then
+                   S(m, iens) = dX(i, j)
+                elseif (index(obs(m)%id,'DY') > 0) then
+                   S(m, iens) = dY(i, j)
+                end if
+             end do
+          end do
+          close(10)
+       else
+          if (master) then 
+             print *,'ERROR: unknown obs type ' // trim(unique_obs(iuobs))
+          end if
+          call stop_mpi()
+       end if
+    end do ! iuobs
+
+    ! some generic QC - relax fitting if the model and obs are too far apart
+    !
+    call obs_QC(nrens, S)
+
+    ! add calculated HA to to observations-<type>.nc files for each data type
+    !
+    do iuobs = 1, nuobs
+       if (master) then
+          nthisobs = 0
+          do m = 1, nobs
+             if (trim(unique_obs(iuobs)) == trim(obs(m) % id)) then
+                nthisobs = nthisobs + 1
+                thisobs(nthisobs) = m
+             end if
+          end do
+
+          ! add forecast values to the observation-<TYPE>.nc files
+          !
+          call add_forecast(unique_obs(iuobs), S(thisobs(1 : nthisobs), :), obs(thisobs(1 : nthisobs)))
+
+          ! append the superobed values (and modified observation error
+          ! variances) to the file with pre-processed observations (SAL.nc,
+          ! TEM.nc, GSAL.nc or GTEM.nc)
+          !
+          if (trim(unique_obs(iuobs)) == 'SAL' .or.&
+               trim(unique_obs(iuobs)) == 'TEM' .or.&
+               trim(unique_obs(iuobs)) == 'GSAL' .or.&
+               trim(unique_obs(iuobs)) == 'GTEM') then
+          
+             call insitu_writeforecast(unique_obs(iuobs), nobs, nrens, S, obs)
+          end if
+       end if
+    end do
+
+    if (master) then
+       print *, 'm_prep_4_EnKF: end calculating S = HA'
+    end if
+
+    x = sum(S, DIM = 2) / real(nrens)   ! [ FM ] The mean forecast interpolated in the obs.space 
+    if (master) print*,'m_prep_4_EnKF: end calculating Hx'
+    if (master) then
+       print *, 'Hx range = ', minval(x), '-', maxval(x)
+       print *, 'mean(Hx) = ', sum(x) / real(nobs)
+    end if
+    if (master) then
+       print *, 'observation range = ', minval(obs % d), '-', maxval(obs % d)
+       print *, 'mean(observation) = ', sum(obs % d) / nobs
+    end if
+    ! Compute HA = HE - mean(HE)
+    !
+    if (master) print*,'prep_4_EnKF(): calculating S = S - x'
+    do j = 1, nrens
+       S(:, j) = S(:, j) - x    ! [ FM ] This is really where we switch from actual model data to anomalies
+    enddo
+    ! Compute innovation
+    !
+    d = obs % d - x     ! [ FM ] This is exactly was is also done in add_forecast. This is the mean innovation.
+    if (master) then
+       print *, '  innovation range = ', minval(d), '-', maxval(d)
+       if (minval(d) < -1000.0d0) then
+          print *, 'm_prep_4_EnKF: error: innovation too small detected'
+          call stop_mpi()
+       end if
+       if (maxval(d) > 1000.0d0) then
+          print *, 'm_prep_4_EnKF: error: innovation too big detected'
+          call stop_mpi()
+       end if
+    end if
+
+  end subroutine prep_4_EnKF
+
+
+  subroutine read_mean_ssh(mean_ssh, nx, ny)
+#if defined (QMPI)
+    use qmpi
+#else
+    use qmpi_fake
+#endif
+    use m_parameters
+
+    integer, intent(in) :: nx, ny
+    real, intent(out):: mean_ssh(nx, ny)
+    logical :: exists
+
+    inquire(file = trim(MEANSSHFNAME), exist = exists)
+    if (.not. exists) then
+       if (master) then
+          print *,'ERROR: read_mean_ssh(): file "', trim(MEANSSHFNAME), '" not found'
+       end if
+       stop
+    end if
+       
+    open (10, file = trim(MEANSSHFNAME), status = 'unknown',form = 'unformatted', action = 'read')
+    read (10) mean_ssh
+    close (10)
+  end subroutine read_mean_ssh
+
+
+  ! This subroutine adds forecast observations (i.e Hx) to the NetCDF
+  ! observation files for each data type.
+  !
+  subroutine add_forecast(obstag, S, obs)
+    use mod_measurement
+    use nfw_mod
+    implicit none
+    
+    character(OBSTYPESTRLEN), intent(in) :: obstag
+    real, dimension(:, :), intent(in) :: S
+    type(measurement), dimension(:) :: obs
+
+    character(STRLEN) :: fname
+    logical :: exists
+    integer :: ncid
+    integer :: dids(2), dimlen
+    logical :: addsobs
+    integer :: for_id, inn_id, forvar_id, slon_id, slat_id,&
+         sdepth_id, sipiv_id, sjpiv_id, sd_id, svar_id,&
+         newvar_id
+    
+    real, allocatable, dimension(:) :: x, Svar, innovation
+  
+    integer :: m, p, o
+
+    write(fname, '(a, a, a)') 'observations-', trim(obstag), '.nc'
+    inquire(file = trim(fname), exist = exists)
+    if (.not. exists) then
+       print *, 'file "', trim(fname), 'not found, skip adding forecast'
+       return
+    else
+       print *, 'dumping forecast to "', trim(fname), '"'
+    end if
+
+    p = size(S, DIM = 1)
+    m = size(S, DIM = 2)
+
+    allocate(x(p), Svar(p), innovation(p))
+
+    x = sum(S, DIM = 2) / real(m);      ! [ FM the mean of S=HA ]
+    Svar = 0.0
+    do o = 1, p
+       Svar(o) = sum((S(o, :) - x(o))** 2)      ! [ FM  thus each row of Svar is the variance (see below) of the forecast]
+    end do
+    Svar = Svar / real(m - 1)
+    innovation = obs % d - x                    ! [ FM ] the innovation for the mean forecast (or mean of the innovation forecasts)
+  
+    addsobs = .false.
+    call nfw_open(fname, nf_write, ncid)
+    call nfw_inq_dimid(fname, ncid, 'nobs', dids(1))
+    call nfw_inq_dimlen(fname, ncid, dids(1), dimlen)
+
+    call nfw_redef(fname, ncid)
+    if (dimlen == p) then
+       dids(2) = dids(1)
+    elseif (.not. nfw_dim_exists(ncid, 'nsobs')) then
+       addsobs = .true.
+       call nfw_def_dim(fname, ncid, 'nsobs', p, dids(2))
+       call nfw_def_var(fname, ncid, 'slon', nf_float, 1, dids(2), slon_id)
+       call nfw_def_var(fname, ncid, 'slat', nf_float, 1, dids(2), slat_id)
+       call nfw_def_var(fname, ncid, 'sdepth', nf_float, 1, dids(2), sdepth_id)
+       call nfw_def_var(fname, ncid, 'sipiv', nf_int, 1, dids(2), sipiv_id)
+       call nfw_def_var(fname, ncid, 'sjpiv', nf_int, 1, dids(2), sjpiv_id)
+       call nfw_def_var(fname, ncid, 'sd', nf_float, 1, dids(2), sd_id)
+       call nfw_def_var(fname, ncid, 'svar', nf_float, 1, dids(2), svar_id)
+    end if
+    if (.not. nfw_var_exists(ncid, 'innovation')) then
+       call nfw_def_var(fname, ncid, 'innovation', nf_double, 1, dids(2), inn_id)
+    else
+       call nfw_inq_varid(fname, ncid, 'innovation', inn_id)
+    end if
+    if (.not. nfw_var_exists(ncid, 'forecast')) then
+       call nfw_def_var(fname, ncid, 'forecast', nf_double, 1, dids(2), for_id)
+    else
+       call nfw_inq_varid(fname, ncid, 'forecast', for_id)
+    end if
+    if (.not. nfw_var_exists(ncid, 'forecast_variance')) then
+       call nfw_def_var(fname, ncid, 'forecast_variance', nf_double, 1, dids(2), forvar_id)
+    else
+       call nfw_inq_varid(fname, ncid, 'forecast_variance', forvar_id)
+    end if
+    if (.not. addsobs) then
+       if (dimlen == p) then
+          if (.not. nfw_var_exists(ncid, 'new_var')) then
+             call nfw_def_var(fname, ncid, 'new_var', nf_double, 1, dids(2), newvar_id)
+          else
+             call nfw_inq_varid(fname, ncid, 'new_var', newvar_id)
+          end if
+       else
+          if (.not. nfw_var_exists(ncid, 'new_svar')) then
+             call nfw_inq_dimid(fname, ncid, 'nsobs', dids(2))
+             call nfw_def_var(fname, ncid, 'new_svar', nf_double, 1, dids(2), newvar_id)
+          else
+             call nfw_inq_varid(fname, ncid, 'new_svar', newvar_id)
+          end if
+       end if
+    end if
+    call nfw_enddef(fname, ncid)
+
+    call nfw_put_var_double(fname, ncid, forvar_id, Svar)
+    call nfw_put_var_double(fname, ncid, for_id, x)
+    call nfw_put_var_double(fname, ncid, inn_id, innovation)
+    if (addsobs) then
+       call nfw_put_var_double(fname, ncid, slon_id, obs % lon)
+       call nfw_put_var_double(fname, ncid, slat_id, obs % lat)
+       call nfw_put_var_double(fname, ncid, sdepth_id, obs % depth)
+       call nfw_put_var_int(fname, ncid, sipiv_id, obs % ipiv)
+       call nfw_put_var_int(fname, ncid, sjpiv_id, obs % jpiv)
+       call nfw_put_var_double(fname, ncid, sd_id, obs % d)
+       call nfw_put_var_double(fname, ncid, svar_id, obs % var)
+    else
+       call nfw_put_var_double(fname, ncid, newvar_id, obs % var)
+    end if
+
+    call nfw_close(fname, ncid)
+
+    deallocate(x)
+    deallocate(Svar)
+    deallocate(innovation)
+  end subroutine add_forecast
+
+end module m_prep_4_EnKF

EnKF-MPI-TOPAZ/m_put_mod_fld.F90

@@ -0,0 +1,65 @@
+module m_put_mod_fld
+! KAL -- This routine puts one of the fields to the restart file, specified
+! KAL -- by name, vertical level and time level. 
+! KAL -- Its a bit dangerous to use -- indx must be updated correctly (max one 
+! KAL -- increment per call of this routine), otherwise there wil be a 
+! KAL -- inconsistency between .a and .b files
+contains
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+! KAL - This is for the new file type
+subroutine put_mod_fld(memfile,fld,iens,cfld,vlevel,tlevel,indx,nx,ny)
+   use mod_raw_io
+   implicit none
+   integer, intent(in) :: nx,ny
+   integer,                intent(in)  :: iens   ! Ensemble member to read
+   real, dimension(nx,ny), intent(in)  :: fld    ! output fld
+   character(len=*),       intent(in)  :: memfile! base name of input files
+   character(len=8),       intent(in)  :: cfld   ! name of fld
+   integer,                intent(in)  :: tlevel ! time level
+   integer,                intent(in)  :: vlevel ! vertical level
+   integer,                intent(in)  :: indx   ! index into file
+
+   real*4:: amin, amax,spval
+   real*4:: writefldr4(nx,ny)
+   integer , parameter :: nop=123
+   integer :: ios
+
+   writefldr4 = real(fld, 4)
+
+   ! Write fld into index of .a file -- Direct access file
+   call writeraw(writefldr4,          &! feltet som skal skrivast
+                 amin,amax,           &! min og max (returnerast fra writeraw)
+                 nx,ny,               &! dimensjon
+                 .false.,spval,       &! feltet vil ikkje faa "no-value" verdiar
+                 memfile//'.a',       &! forelopig filnavn...
+                 indx)                 ! indexen i .a fila
+
+   ! Skriv header -- .b fil -- Hold tunga rett i munnen her og utanfor rutina, 
+   ! ellers blir det inkonsistens mellom .a og .b filer - dette vil fangast opp 
+   ! av postprosessering. Dette er tungvint men vanskelig aa omgaa fordi
+   ! .b-fila er sekvensiell mens .a fila er direct access.
+   if (indx==1) then
+      ! forste indeks - vi overskriv evt gamle filer
+      open(nop,file=memfile//'.b',status='replace')
+   else
+      ! Ellers legg vi til 
+      open(nop,file=memfile//'.b',status='old', position='append')
+   end if
+
+   ! Skriv i vei !
+   write(nop,4100,iostat=ios) cfld,vlevel,tlevel,amin,amax
+   close(nop)
+
+4100  format(a,': layer,tlevel,range = ',i3,i3,2x,1p2e16.7)
+!     format (a8,23x,i3,i3,2x,2e16.7)
+
+
+end subroutine
+
+
+
+end module m_put_mod_fld
+
+

EnKF-MPI-TOPAZ/m_random.F90

@@ -0,0 +1,51 @@
+module m_random
+
+contains
+
+  subroutine random(work1,n)
+    !  Returns a vector of random values N(variance=1,mean=0)
+    implicit none
+    integer, intent(in) :: n
+    real,   intent(out) :: work1(n)
+    real,   allocatable :: work2(:)
+    real, parameter   ::  pi=3.141592653589
+
+    allocate (work2(n))
+
+    call random_number(work1)
+    call random_number(work2)
+    work1= sqrt(-2.0*log(work1))*cos(2.0*pi*work2)
+
+    deallocate(work2)
+  end subroutine random
+
+
+  subroutine randn(n, vect)
+    implicit none
+    integer, intent(in) :: n
+    real, intent(out) :: vect(n)
+
+    integer :: i
+    real :: a(2), r
+
+    i = 0
+    do while (i < n)
+       call random_number(a)
+       a = 2.0 * a - 1.0
+       r = a(1) * a(1) + a(2) * a(2)
+       if (r > 1.0) then
+          cycle
+       end if
+       i = i + 1
+       ! assume that r is never equal to 0 - PS
+       r = sqrt(-2.0 * log(r) / r);
+       vect(i) = r * a(1);
+       if (i == n) then
+          exit
+       end if
+       i = i + 1
+       vect(i) = r * a(2);
+    end do
+  end subroutine randn
+
+end module m_random

EnKF-MPI-TOPAZ/m_read_icemod.F90

@@ -0,0 +1,63 @@
+MODULE m_read_icemod
+! Francois Massonnet, UCL, 2013
+! Reads data from icemod file (instead of classically restart files).
+! This is required when doing data assimilation of OSISAF sea ice drift
+! computed over several hours/days. Indeed, the restart only gives a
+! snapshot of the state of the system while the icemod records the time
+! average. The icemod file should have one time slice.
+USE NETCDF
+#if defined (QMPI)
+  use qmpi
+#else
+  use qmpi_fake
+#endif
+
+CONTAINS
+        SUBROUTINE read_icemod(fld,k,enslist,cfld,nx,ny)
+        IMPLICIT NONE
+
+        real,dimension(nx,ny),intent(inout):: fld    ! output fl
+        character(len=*),       intent(in) :: cfld   ! name of fld
+        integer,                intent(in) :: k      ! Index to enslist
+        integer,dimension(:),   intent(in) :: enslist! List of existing ensemble members
+        integer,                intent(in) :: nx,ny  ! Grid dimension
+        integer                                 :: iens
+        integer                         :: error, ncid,varID
+        character(len=3)  :: cmem
+        character(len=99) :: cfile
+        logical           :: exf
+        iens = enslist(k)
+        write(cmem,'(i3.3)') 100+iens  ! iens=1 gives cmem = 101
+        
+        cfile='icemod_'//cmem//'.nc'
+
+        inquire(file=cfile,  exist=exf)
+        if (.not.exf) then
+                if (master) print *, '(read_icemod): Icemod file '//cfile//' missing!'
+                call stop_mpi()
+        end if
+
+        error = nf90_open(trim(cfile),nf90_Write,ncid); if (error.ne.nf90_noerr) call handle_err(error, "opening")
+        error = nf90_inq_varid(ncid, trim(cfld), varID); if (error.ne.nf90_noerr) call handle_err(error, "inquiring varID")       
+        error = nf90_get_var(ncid, varID, fld); if (error.ne.nf90_noerr) call handle_err(error, "getting 2D variable")
+ 
+        END SUBROUTINE read_icemod
+
+        subroutine handle_err(status, infomsg)
+          integer,            intent ( in) :: status
+          character(len = *), intent ( in), optional :: infomsg
+          if(status /= nf90_noerr) then
+             if (master) then
+                if (present(infomsg)) then
+                   print *, 'Error while '//infomsg//' - '//trim(nf90_strerror(status))
+                else
+                   print *, trim(nf90_strerror(status))
+                endif ! opt arg
+                print *,'(io_mod_fld)'
+             endif ! only master outputs
+             call stop_mpi()
+          end if ! check error status
+        end subroutine handle_err
+ 
+
+END MODULE m_read_icemod

EnKF-MPI-TOPAZ/m_set_random_seed2.F90

@@ -0,0 +1,96 @@
+module m_set_random_seed2
+contains
+subroutine set_random_seed1
+! Sets a random seed based on the system and wall clock time
+! Used to work on IBM Regatta Power 4 ("TRE") but not on Cray XE6m ("Hexagon") 
+! Where it always returned zero. 
+#if defined (QMPI) 
+   use qmpi
+#else
+   use qmpi_fake
+#endif
+   implicit none 
+
+   integer , dimension(8)::val
+   integer cnt
+   integer sze
+   integer, allocatable, dimension(:):: pt
+#if defined (QMPI)
+   integer :: q
+#endif
+
+   call DATE_AND_TIME(values=val)
+   !if(master)print*,'TIME', val
+   call SYSTEM_CLOCK(count=cnt)
+   !if(master)print*,'CLOCK', cnt
+   call RANDOM_SEED(size=sze)
+   !if(master)print*,'SEED', sze
+   allocate(pt(sze))
+   pt(1) = val(8)*val(3)
+   pt(2) = cnt
+   ! KAL --- spread random seed to tiles, this makes sure that m_sample2D 
+   ! KAL --- produces the same perturbations across processes
+#if defined (QMPI)
+   if (master) then
+      do q=2,qmpi_num_proc
+         call send(pt,q-1)
+      end do
+   else
+      call receive(pt,0)
+   end if
+#endif
+   call RANDOM_SEED(put=pt)
+   !if(master)print*,'RANDOM SEED', pt
+   deallocate(pt)
+end subroutine set_random_seed1
+
+! --- Sets a random seed based on the wall clock time
+! ES: Tested and approved on Cray 
+      subroutine set_random_seed2
+#if defined (QMPI) 
+   use qmpi
+#else
+   use qmpi_fake
+#endif
+      implicit none 
+      integer , dimension(8)::val
+      integer cnt,q
+      integer sze
+! --- Arrays for random seed
+      integer, allocatable, dimension(:):: pt  
+      real   , allocatable, dimension(:):: rpt
+!
+      call DATE_AND_TIME(values=val)
+      if (sum(val) == 0) then 
+         print*, "Check that date_and_time is available on your computer"
+         call stop_mpi
+      endif 
+      call RANDOM_SEED(size=sze)
+      allocate(pt(sze)) 
+      allocate(rpt(sze))
+! --- Init - assumes seed is set in some way based on clock, 
+! --- date etc. (not specified in fortran standard). Sometimes
+! --- this initial seed is just set every second 
+      call RANDOM_SEED   
+! --- Retrieve initialized seed. val(8) is milliseconds - 
+      call RANDOM_SEED(GET=pt) 
+! --- this randomizes stuff if random_seed is not updated often 
+! --- enough. synchronize seed across tasks (needed if pseudo 
+! --- is paralellized some day)
+      rpt = pt * (val(8)-500)  
+#if defined (QMPI)
+   if (master) then
+      do q=2,qmpi_num_proc
+         call send(rpt,q-1)
+      end do
+   else
+      call receive(rpt,0)
+   end if
+#endif          
+      pt=int(rpt)
+      call RANDOM_SEED(put=pt)
+      deallocate( pt)
+      deallocate(rpt)
+      end subroutine set_random_seed2
+
+end module m_set_random_seed2

EnKF-MPI-TOPAZ/m_spherdist.F90

@@ -0,0 +1,30 @@
+module m_spherdist
+
+contains
+
+  ! Computes the distance between geo. pos. lon1, lat1 and lon2, lat2.
+  ! http://en.wikipedia.org/wiki/Great-circle_distance
+  !
+  ! Input is in degrees, output in meters
+  !
+  !
+  !FC: 29/02/12 add min max to avoid NaN from acos
+real function spherdist(lon1, lat1, lon2, lat2)
+  implicit none
+
+  real(8), intent(in) :: lon1, lat1, lon2, lat2 ! pos. in degrees
+
+  real(8), parameter :: INVRAD = 3.14159265358979323846d0 / 180.0d0
+  real, parameter :: REARTH = 6371000.0d0
+  real  :: rlon1, rlat1, rlon2, rlat2 ! pos. in radians
+
+  rlon1 = lon1 * INVRAD !lon1 in rad
+  rlat1 = lat1 * INVRAD !90-lat1 in rad 
+  rlon2 = lon2 * INVRAD ! lon2 in rad
+  rlat2 = lat2 * INVRAD !90 - lat2 in rad 
+
+  spherdist = REARTH * acos(min(max(sin(rlat1) * sin(rlat2)&
+         + cos(rlat1) * cos(rlat2) * cos(rlon1 - rlon2),-1.),1.))
+end function spherdist
+
+end module m_spherdist

EnKF-MPI-TOPAZ/m_uobs.F90

@@ -0,0 +1,105 @@
+! File:          m_uobs.F90
+!
+! Created:       11 August 2010
+!
+! Last modified: 11.8.2010
+!
+! Author:        Pavel Sakov
+!                NERSC
+!
+! Purpose:       Handle different observation types.
+!
+! Description:   This module is in charge of sorting of observations by types
+!                and storing the results
+!
+! Modifications: None
+
+module m_uobs
+#if defined (QMPI)
+    use qmpi
+#else
+    use qmpi_fake
+#endif
+  use mod_measurement
+  implicit none
+
+  public uobs_get
+  
+  integer, parameter, private :: MAXNUOBS = 19
+
+  integer, public :: nuobs
+  character(OBSTYPESTRLEN), public :: unique_obs(MAXNUOBS)
+  integer, public :: nobseach(MAXNUOBS)
+  integer :: uobs_begin(MAXNUOBS), uobs_end(MAXNUOBS)
+
+contains
+
+  subroutine uobs_get(tags, nrobs, master)
+    implicit none
+    integer , intent(in) :: nrobs
+    logical , intent(in) :: master
+    character(OBSTYPESTRLEN), intent(in) :: tags(nrobs)
+
+    logical :: obsmatch
+    integer :: o, uo
+
+    nobseach = 0
+
+    ! check for unique obs
+    if (master) then
+       print '(a)', ' EnKF: getting unique observations '
+    end if
+    nuobs = 0
+    unique_obs = ''
+    do o = 1, nrobs
+       obsmatch = .false.
+       do uo = 1, nuobs
+          if (trim(tags(o)) == trim(unique_obs(uo))) then
+             obsmatch = .true.
+             nobseach(uo) = nobseach(uo) + 1
+             exit
+          end if
+       end do
+       if (.not. obsmatch) then
+          nuobs = nuobs + 1
+          nobseach(nuobs) = 1
+          if (nuobs > MAXNUOBS) then
+             if (master) then
+                print *, 'ERROR: uobs_get(): # of unique obs = ', nuobs,&
+                     ' > MAXNUOBS = ', MAXNUOBS
+                print *, '  obs # = ', o, ', tag = ', trim(tags(o))
+             end if
+             stop
+          end if
+          unique_obs(nuobs) = trim(tags(o))
+       end if
+    end do
+    if (master) then
+       do uo = 1, nuobs
+          print '(a, i2, a, a, a, i7, a)', '   obs variable  ', uo, ' -- ',&
+               trim(unique_obs(uo)), ',', nobseach(uo), ' observations'
+       end do
+    end if
+    uobs_begin(1) = 1
+    uobs_end(1) = nobseach(1)
+    do uo = 2, nuobs
+       uobs_begin(uo) = uobs_end(uo - 1) + 1
+       uobs_end(uo) = uobs_begin(uo) + nobseach(uo) - 1
+    end do
+    if (master) then
+       do uo = 1, nuobs
+          do o = uobs_begin(uo), uobs_end(uo)
+             if (trim(tags(o)) /= trim(unique_obs(uo))) then
+                print *, 'ERROR: uobs_get(): uinique observations not ',&
+                     'continuous in observation array'
+                stop
+             end if
+          end do
+       end do
+    end if
+    if (master) then
+       print *
+    end if
+  end subroutine uobs_get
+
+end module m_uobs

EnKF-MPI-TOPAZ/make.inc

@@ -0,0 +1 @@
+Config/make.mn4

EnKF-MPI-TOPAZ/makefile

@@ -0,0 +1,79 @@
+MPI = YES
+
+include ./make.inc
+
+SHELL = /bin/bash
+VPATH = .:TMP
+
+PROGS = EnKF
+
+all: $(PROGS)
+
+ENKF_SRC_F90 = \
+qmpi.F90\
+m_parameters.F90\
+m_Generate_element_Si.F90\
+mod_analysisfields.F90\
+m_confmap.F90\
+mod_measurement.F90\
+m_oldtonew.F90\
+m_random.F90\
+m_spherdist.F90\
+distribute.F90\
+m_bilincoeff.F90\
+m_get_mod_fld.F90\
+m_get_mod_grid.F90\
+m_get_mod_xyz.F90\
+m_get_mod_nrens.F90\
+m_io_mod_fld.F90\
+m_read_icemod.F90\
+m_insitu.F90\
+m_local_analysis.F90\
+m_obs.F90\
+m_parse_blkdat.F90\
+m_pivotp.F90\
+m_point2nc.F90\
+m_prep_4_EnKF.F90\
+m_put_mod_fld.F90\
+m_set_random_seed2.F90\
+m_uobs.F90\
+nfw.F90\
+EnKF.F90
+
+ENKF_SRC_F77 = mod_raw_io.F
+
+ENKF_SRC_C = order.c
+
+ENKF_OBJ = $(ENKF_SRC_C:.c=.o) $(ENKF_SRC_F77:.F=.o) $(ENKF_SRC_F90:.F90=.o)
+
+# some fine tuning; add more dependancies when/if required 
+#
+m_obs.o: m_uobs.o
+m_Generate_element_Si.o: m_parse_blkdat.o mod_measurement.o m_get_mod_fld.o m_insitu.o m_obs.o
+m_insitu.o: nfw.o mod_measurement.o m_get_mod_xyz.o m_io_mod_fld.o 
+m_local_analysis.o: mod_measurement.o m_point2nc.o m_parameters.o
+
+EnKF: $(ENKF_OBJ)
+	@echo "->EnKF"
+	@cd ./TMP ; $(LD) $(LINKFLAGS) -o ../EnKF $(ENKF_OBJ) $(LIBS) 
+
+$(ENKF_OBJ): makefile make.inc MODEL.CPP
+
+clean:
+	@rm -f TMP/*.*  $(PROGS)
+
+%.o: %.F90
+	@echo "  $*".F90
+	@rm -f ./TMP/$*.f90
+	@cat MODEL.CPP $*.F90 | $(CPP) $(CPPFLAGS) > ./TMP/$*.f90
+	@cd ./TMP ; $(CF90) -c $(FFLAGS) $(F90FLG) -o $*.o $*.f90
+
+%.o: %.F
+	@echo "  $*".F
+	@rm -f ./TMP/$*.f
+	@cat MODEL.CPP $*.F | $(CPP) $(CPPFLAGS)  > ./TMP/$*.f
+	@cd ./TMP ; $(CF77) -c $(FFLAGS) $(F77FLG) -o $*.o $*.f  
+
+%.o: %.c
+	@echo "  $*".c
+	@cd ./TMP ; $(CC) -c $(CFLAGS) -o $*.o -I.. ../$*.c

EnKF-MPI-TOPAZ/mod_analysisfields.F90

@@ -0,0 +1,156 @@
+!KAL -- this module allows us to fine-tune the fields
+!KAL -- we wish to include in the analysis. The new
+!KAL -- layout of the EnKF makes it possible to specify fields
+!KAL -- to analyze at run-time rather than at compile-time
+!KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+!KAL --
+!KAL -- Module variables:
+!KAL --    numfields   - total number of fields to process
+!KAL --    fieldnames  - the names of the fields we wish to analyze
+!KAL --    fieldlevel  - the levels of the associated fields
+!KAL --    fieldtype   - in which file the field can be found: 
+!ckb --                  1: ice, 2: ocean, 3: ice parameter, 
+!ckb --                  4: ocean parameter
+!KAL --
+!KAL -- Ex: If we only want to assimilate temperatures in layer
+!KAL --     one and two, numfields, fieldnames and fieldlevel 
+!KAL --     would look like:
+!KAL --
+!KAL --     numfields=2                                 
+!KAL --     fieldnames (1)='temp', fieldnames (2)='temp'
+!KAL --     fieldlevel (1)=     1, fieldlevel (2)=2     (???)
+!ckb --     fieldtype  (1)=     2, fieldtype  (2)=2
+!KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+!KAL -- The file "analysisfields.in" specifies the fields to 
+!KAL -- inlude in the analysis. Format of one line is fieldname
+!ckb -- first layer, last layer and fieldtype. For example:
+!KAL --
+!KAL -- fieldname       1 31  1
+!KAL -- 12345678901234567890123456789012345678901234567890
+!KAL --
+!KAL -- Fortran format for one line is '(a14,3i3)'
+!KAL --
+!KAL -- Example: to specify that we want temperature and salinity 
+!ckb --          in layers 1-31 (ocean variables, type 2) to be
+!ckb --           updated, as well as ice concentration (layer 0,
+!ckb --           type 1), and the atmosphere-ice-drag coefficient,
+!ckb --           specify:
+!ckb --
+!ckb -- a_i_htc1        0  0  1
+!ckb -- v_i_htc1        0  0  1
+!ckb -- tempt_il3_htc5  0  0  1
+!ckb -- ub              1 31  2
+!ckb -- vb              1 31  2
+!ckb -- cai             0  0  3
+!KAL -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+! [FM,CKB] Changed to allow for column "parameter"
+
+
+
+
+
+module mod_analysisfields
+
+character(len=*), parameter :: infile='analysisfields.in'
+integer,save :: numfields
+character(len=14), dimension(:), save, allocatable:: fieldnames
+integer          , dimension(:), save, allocatable:: fieldlevel 
+integer          , dimension(:), save, allocatable:: fieldtype
+
+contains
+
+   integer function get_nrfields()
+
+#if defined (QMPI)
+   use qmpi
+#else
+   use qmpi_fake
+#endif
+
+   implicit none
+   integer :: ios,first,last,type
+   logical :: ex
+   character(len=14) :: char14
+
+   inquire(exist=ex,file=infile)
+   if (.not. ex) then
+      if (master) print *,'Could not find '//infile
+      call stop_mpi()
+   end if
+
+   open(10,status='old',form='formatted',file=infile)
+   ios=0
+   get_nrfields=0
+   do while (ios==0)
+      read(10,100,iostat=ios) char14,first,last,type
+      if (ios==0) get_nrfields=get_nrfields+last-first+1
+   end do
+   close(10)
+   100 format (a14,3i3)
+   end function
+
+
+
+   subroutine get_analysisfields()
+
+#if defined (QMPI)
+   use qmpi
+#else
+   use qmpi_fake
+#endif
+
+   implicit none
+   integer :: first,last,type,k,nfld,ios
+   logical :: ex
+   character(len=14) :: char14
+
+   numfields=get_nrfields()
+   if (master) print *,'numfields is ',numfields
+   if (numfields<=0 .or.numfields > 18000) then ! FM I Changed 600 to 18000
+      if (master) print *,'(get_analysisfields) numfields is higher than max allowed setting or = 0'
+      call stop_mpi()
+   end if
+   allocate(fieldnames(numfields))
+   allocate(fieldlevel(numfields))
+   allocate(fieldtype(numfields))
+
+
+   inquire(exist=ex,file=infile)
+   if (.not. ex) then
+      if (master) print *,'Could not find '//infile
+      call stop_mpi()
+   end if
+
+   open(10,status='old',form='formatted',file=infile)
+   ios=0
+   nfld=0
+   do while (ios==0)
+      read(10,100,iostat=ios) char14,first,last,type
+      if (ios==0) then
+         do k=first,last
+            fieldnames (nfld+k-first+1)=char14
+            fieldlevel (nfld+k-first+1)=k
+            fieldtype  (nfld+k-first+1)=type
+         end do
+         nfld=nfld+last-first+1
+      end if
+   end do
+   close(10)
+   100 format (a14,3i3)
+
+   if (nfld/=numfields) then
+      if (master) print *,'An error occured when reading '//infile
+      call stop_mpi()
+   end if
+
+   ! List fields used in analysis
+   print *, "(mod_analysisfields) Fields used in analysis:"
+   print *, "(mod_analysisfields) --- removed to reduce output ---"
+   !do k=1,numfields
+   !   if (master) print *,fieldnames(k),fieldlevel(k),fieldtype(k)
+   !end do
+
+   end subroutine
+end module mod_analysisfields
+

EnKF-MPI-TOPAZ/mod_measurement.F90

@@ -0,0 +1,32 @@
+module mod_measurement
+
+  integer, parameter, public :: OBSTYPESTRLEN = 5
+
+  type measurement
+     real d                       ! Measurement value
+     real var                     ! Error variance of measurement
+     character(len=OBSTYPESTRLEN) id ! Type, can be one of those:
+                                  ! 'SST' 'SLA' 'ICEC' 'SAL' 'TEM'
+                                  ! 'GSAL' 'GTEM' 'TSLA'
+     real lon                     ! Longitude position
+     real lat                     ! Latitude position
+     real depth                   ! depths of position 
+     integer ipiv                 ! i-pivot point in grid
+     integer jpiv                 ! j-pivot point in grid
+     integer ns                   ! representativity in mod cells (meas. support)
+                                  ! ns=0 means: point measurements
+                                  ! used in m_Generate_element_Sij.F90
+     real a1                      ! bilinear coefficient (for ni=0)
+     real a2                      ! bilinear coefficient
+     real a3                      ! bilinear coefficient
+     real a4                      ! bilinear coefficient
+     logical status               ! active or not
+     integer i_orig_grid          ! KAL - orig grid index for ice drift
+                                  ! processing
+     integer j_orig_grid          ! orig grid index
+     real h                       ! PS - layer thickness, sorry for that
+     integer date                 ! FanF - age of the data 
+     integer orig_id              ! PS - used in superobing
+  end type measurement
+
+end module mod_measurement

EnKF-MPI-TOPAZ/mod_raw_io.F

@@ -0,0 +1,394 @@
+      module mod_raw_io
+      contains
+
+
+! Modified from Alan Wallcraft's RAW routine by Knut Liseter @ NERSC
+! So far only the "I" in "IO" is present
+      SUBROUTINE READRAW(A,AMN,AMX,IDM,JDM,LSPVAL,SPVAL,CFILE1,K)
+      IMPLICIT NONE
+C
+      REAL*4     SPVALH
+      PARAMETER (SPVALH=1.0E30_4)
+C
+      REAL*4,        INTENT(OUT) :: A(IDM,JDM)
+      REAL*4,        INTENT(OUT) :: AMN,AMX
+      INTEGER,       INTENT(IN)  :: IDM,JDM
+      LOGICAL,       INTENT(IN)  :: LSPVAL
+      REAL*4,        INTENT(INOUT)  :: SPVAL
+      INTEGER,       INTENT(IN)  :: K
+      CHARACTER(len=*), INTENT(IN)  :: CFILE1
+C
+      REAL*4 :: PADA(4096)
+C
+C     MOST OF WORK IS DONE HERE.
+C
+
+      INTEGER      LEN_TRIM
+      INTEGER      I,J,IOS,NRECL
+      INTEGER NPAD
+C
+      IF(.NOT.LSPVAL) THEN
+        SPVAL = SPVALH
+      ENDIF
+C
+!!! Calculate the number of elements padded!!!!!!!!!!!!!!!!!!!!!!!!
+      NPAD=GET_NPAD(IDM,JDM)
+C
+      INQUIRE( IOLENGTH=NRECL) A,PADA(1:NPAD)
+C     
+C     
+      OPEN(UNIT=11, FILE=CFILE1, FORM='UNFORMATTED', STATUS='old',
+     +         ACCESS='DIRECT', RECL=NRECL, IOSTAT=IOS, ACTION='READ')
+      IF     (IOS.NE.0) THEN
+        write(6,*) 'Error: can''t open ',CFILE1(1:LEN_TRIM(CFILE1))
+        write(6,*) 'ios   = ',ios
+        write(6,*) 'nrecl = ',nrecl
+        CALL EXIT(3)
+      ENDIF
+C
+      READ(11,REC=K,IOSTAT=IOS) A
+      close(11)
+C
+      IF     (IOS.NE.0) THEN
+        WRITE(6,*) 'can''t read record ',K,
+     &             ' from '//CFILE1(1:LEN_TRIM(CFILE1))
+        CALL EXIT(4)
+      ENDIF
+C
+      AMN =  SPVALH
+      AMX = -SPVALH
+      DO J= 1,JDM
+      DO I=1,IDM
+         IF     (A(I,J).LE.SPVALH) THEN
+            AMN = MIN(real(AMN, 4), real(A(I,J), 4))
+            AMX = MAX(real(AMX, 4), real(A(I,J), 4))
+         ELSEIF (LSPVAL) THEN
+            A(I,J) = SPVAL
+         ENDIF
+      END DO
+      END DO
+C                 
+      RETURN
+      END SUBROUTINE
+
+! Modified from Alan Wallcraft's RAW routine by Knut Liseter @ NERSC
+! This wll be the  "O" in "IO" is present
+      SUBROUTINE WRITERAW(A,AMN,AMX,IDM,JDM,LSPVAL,SPVAL,CFILE1,K)
+      IMPLICIT NONE
+C
+      REAL*4     SPVALH
+      PARAMETER (SPVALH=1.0e30_4)
+C
+      REAL*4,        INTENT(INOUT) :: A(IDM,JDM)
+      REAL*4,        INTENT(OUT)   :: AMN,AMX
+      INTEGER,       INTENT(IN)    :: IDM,JDM
+      LOGICAL,       INTENT(IN)    :: LSPVAL
+      REAL*4,        INTENT(INOUT) :: SPVAL
+      INTEGER,       INTENT(IN)    :: K
+      CHARACTER(len=*), INTENT(IN) :: CFILE1
+C
+      REAL*4 :: PADA(4096)
+C
+C     MOST OF WORK IS DONE HERE.
+C
+
+      INTEGER      LEN_TRIM
+      INTEGER      I,J,IOS,NRECL
+      INTEGER NPAD
+C
+      IF(.NOT.LSPVAL) THEN
+        SPVAL = SPVALH
+      ENDIF
+C
+!!! Calculate the number of elements padded!!!!!!!!!!!!!!!!!!!!!!!!
+      NPAD=GET_NPAD(IDM,JDM)
+C
+      PADA=0.
+      INQUIRE( IOLENGTH=NRECL) A,PADA(1:NPAD)
+C     
+C     
+      OPEN(UNIT=11, FILE=CFILE1, FORM='UNFORMATTED', STATUS='unknown',
+     +         ACCESS='DIRECT', RECL=NRECL, IOSTAT=IOS)
+      IF     (IOS.NE.0) THEN
+        write(6,*) 'Error: can''t open ',CFILE1(1:LEN_TRIM(CFILE1))
+        write(6,*) 'ios   = ',ios
+        write(6,*) 'nrecl = ',nrecl
+        CALL EXIT(3)
+      ENDIF
+C
+      WRITE(11,REC=K,IOSTAT=IOS) A,PADA(1:NPAD)
+      close(11)
+C
+      IF     (IOS.NE.0) THEN
+        WRITE(6,*) 'can''t write record ',K,
+     &             ' from '//CFILE1(1:LEN_TRIM(CFILE1))
+        CALL EXIT(4)
+      ENDIF
+C
+      AMN =  SPVALH
+      AMX = -SPVALH
+      DO J= 1,JDM
+      DO I=1,IDM
+         IF     (A(I,J).LE.SPVALH) THEN
+            AMN = MIN(real(AMN, 4), real(A(I,J), 4))
+            AMX = MAX(real(AMX, 4), real(A(I,J), 4))
+         ELSEIF (LSPVAL) THEN
+            A(I,J) = SPVAL
+         ENDIF
+      END DO
+      END DO
+C                 
+      RETURN
+      END SUBROUTINE
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Routine to get index of fields in data file (.a) from header file (.b)
+      subroutine rst_index_from_header(fname,cfld,vlevel,tlevel,
+     &                                 indx,bmin,bmax,skiphdr) 
+      implicit none
+      character(len=*), intent(in) :: fname     ! filename without extention
+      character(len=*), intent(in) :: cfld      ! variable name
+      integer         , intent(in) :: tlevel    ! time level
+      integer         , intent(in) :: vlevel    ! vertical level
+      integer         , intent(out):: indx      ! index in .a file
+      real            , intent(out):: bmin,bmax ! min and max from b file
+      logical         , intent(in) :: skiphdr
+
+      integer :: itlevel, ivlevel
+      character(len=8) :: icfld
+      integer :: ios,i
+      integer :: nskip_rst,nop
+      logical :: match, ex
+
+      nskip_rst=2
+      nop = 999
+
+      ! Open file
+      inquire(exist=ex,file=trim(fname))
+      if (.not. ex) then
+         print *,'file '//trim(fname)//' is not present'
+         call exit(1)
+      end if
+      open(nop,file=trim(fname),status='old',action='read')
+
+      ! Skip first nskip lines
+      if (skiphdr) then
+         do i=1,nskip_rst
+            read(nop,*)
+         end do
+      end if
+
+      match=.false.
+      indx=0
+      ios=0
+      do while (ios==0 .and. .not.match)
+         read(nop,117,iostat=ios) icfld,ivlevel,itlevel,bmin,bmax
+         match= icfld==cfld .and. ivlevel==vlevel .and. itlevel==tlevel
+         indx=indx+1
+         !print *,icfld,itlevel,ivlevel,bmin,bmax
+      end do
+
+      close(nop)
+
+      if (.not.match) then
+         !print *,'Could not find field '//cfld
+         !print *,'Vertical level :',vlevel
+         !print *,'Time     level :',tlevel
+         indx=-1
+         !call exit(1) ! Always return to caller
+      endif
+
+  117 format (a8,23x,i3,i3,2x,2e16.7)
+
+      end subroutine
+      
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Routine to get field desc in  header file (.b) from index in data file (.a)
+      subroutine rst_header_from_index(fname,cfld,vlevel,tlevel,
+     &                                 indx,bmin,bmax,skiphdr) 
+      implicit none
+      character(len=*), intent(in)  :: fname     ! filename without extention
+      character(len=8), intent(out) :: cfld      ! variable name
+      integer         , intent(out) :: tlevel    ! time level
+      integer         , intent(out) :: vlevel    ! vertical level
+      integer         , intent(in)  :: indx      ! index in .a file
+      real            , intent(out) :: bmin,bmax ! min and max from b file
+      logical         , intent(in ) :: skiphdr   ! Skip header of .b file
+
+      integer :: ios,i
+      integer :: nskip_rst,nop
+      logical :: ex
+
+
+      nskip_rst=2
+      nop = 999
+
+      ! Open file
+      inquire(exist=ex,file=trim(fname))
+      if (.not. ex) then
+         print *,'file '//trim(fname)//' not present'
+         call exit(1)
+      end if
+      open(nop,file=trim(fname),status='old',action='read')
+
+
+      ! Skip first nskip + index-1 lines
+      !print *,'hei'
+      if (skiphdr) then
+         do i=1,nskip_rst
+            read(nop,*)
+         end do
+      end if
+      do i=1,indx-1
+         read(nop,*)
+      end do
+      read(nop,117,iostat=ios) cfld,vlevel,tlevel,bmin,bmax
+      close(nop)
+
+      if (ios/=0) then
+         !print *,'Could not get info from  index',indx
+         !call exit(1)
+         cfld=''
+         tlevel=-1
+         vlevel=-1
+      endif
+
+  117 format (a8,23x,i3,i3,2x,2e16.7)
+
+      end subroutine
+      
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Routine to get index of fields in regional grid file (.a) from header file (.b)
+      subroutine grid_index_from_header(fname,cfld,indx,bmin,bmax
+     &                                  ,skiphdr) 
+      implicit none
+      character(len=*), intent(in) :: fname     ! filename without extention
+      character(len=*), intent(in) :: cfld      ! variable name
+      integer         , intent(out):: indx      ! index in .a file
+      real            , intent(out):: bmin,bmax ! min and max from b file
+      logical         , intent(in) :: skiphdr
+
+      character(len=4) :: icfld
+      character*80 :: cline
+      integer :: ios,i
+      integer :: nskip_grid,nop
+      logical :: match, ex
+
+      nskip_grid=3
+      nop = 999
+
+      ! Open file
+      inquire(exist=ex,file=trim(fname))
+      if (.not. ex) then
+         print *,'file '//trim(fname)//' is not present'
+         call exit(1)
+      end if
+      open(nop,file=trim(fname),status='old',action='read')
+
+
+      ! Skip first nskip lines
+      if (skiphdr) then
+         do i=1,nskip_grid
+            read(nop,*)
+         end do
+      end if
+
+      match=.false.
+      indx=0
+      ios=0
+      do while (ios==0 .and. .not.match)
+         read(nop,'(a)') cline
+         icfld=cline(1:4)
+         i=index(cline,'=')
+         read (cline(i+1:),*) bmin,bmax
+         match= trim(icfld)==trim(cfld)
+         indx=indx+1
+      end do
+
+      close(nop)
+
+      if (.not.match) then
+         indx=-1
+      endif
+      end subroutine grid_index_from_header
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Routine to get index of fields in regional grid file (.a) from header file (.b)
+      subroutine daily_index_from_header(fname,cfld,coord,indx,
+     &   bmin,bmax)
+      implicit none
+      character(len=*), intent(in) :: fname     ! filename without extention
+      character(len=*), intent(in) :: cfld      ! variable name
+      integer         , intent(in) :: coord     ! vertical coordinate
+      integer         , intent(out):: indx      ! index in .a file
+      real            , intent(out):: bmin,bmax ! min and max from b file
+
+      logical, parameter:: skiphdr=.true.
+      character(len=5) :: char5
+      character(len=8) :: char8
+      integer :: ios
+      integer :: nop
+      logical :: match, ex
+      real    :: dens,rday
+      integer :: lcoord,nstep
+
+      nop = 999
+
+      ! Open file
+      inquire(exist=ex,file=trim(fname))
+      if (.not. ex) then
+         print *,'file '//trim(fname)//' is not present'
+         call exit(1)
+      end if
+      open(nop,file=trim(fname),status='old')
+
+      ! Skip first nskip lines
+      if (skiphdr) then
+         do while (char5/='field' .and. ios==0)
+            read(nop,'(a5)',iostat=ios) char5
+         end do
+      end if
+
+      ! Read until we get the field we want
+      indx=0
+      ios=0
+      char8=''
+      lcoord=-1
+      match=.false.
+      do while(.not.match .and. ios==0)
+         read(nop,117,iostat=ios) char8,nstep,rday,lcoord,dens,
+     &                            bmin,bmax
+         match=(trim(cfld)==trim(char8) .and. lcoord==coord)
+         indx=indx+1
+      end do
+      close(nop)
+
+      if (.not.match) then
+         indx=-1
+      endif
+
+  117 format (a8,' = ',i11,f11.2,i3,f7.3,1p2e16.7)
+      end subroutine daily_index_from_header
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+
+
+
+
+      INTEGER FUNCTION GET_NPAD(IDM,JDM)
+      IMPLICIT NONE
+      INTEGER, INTENT(IN) :: IDM,JDM
+         GET_NPAD = 4096 - MOD(IDM*JDM,4096)
+         GET_NPAD = mod(GET_NPAD,4096)
+      END FUNCTION
+      end module mod_raw_io

EnKF-MPI-TOPAZ/namelist.txt

@@ -0,0 +1,20 @@
+&method
+     methodtag    = "DEnKF"
+/
+&ensemble
+     enssize      = 0
+/
+&localisation
+     locfuntag    = "Gaspari-Cohn"
+     locrad       = 800.0
+/
+&moderation
+     infl         = 1.0
+     rfactor1     = 1.0
+     rfactor2     = 2.0
+     kfactor      = 2.0
+/
+&files
+/
+&prmest
+/

EnKF-MPI-TOPAZ/nfw.F90

@@ -0,0 +1,698 @@
+!
+! File: nfw.f90
+!
+! Author: Pavel Sakov, CSIRO Marine Research
+!
+! Created: 17 March 2005
+!
+! Purpose: Contains wrappers to netcdf functions, mainly for easier
+!          error handling.
+! 
+! Description:
+!
+!          Each subroutine in nfw.f90 is a simple wrapper of a similar
+!          function in the NetCDF Fortran interface. The rules of use are
+!          pretty simple: for a given NetCDF Fortran function, replace
+!          prefix "nf_" by "nfw_" and add the NetCDF file name as the
+!          first argument.
+!
+!          Here is the current list of subroutines in nfw_mod:
+!
+!          nfw_create(fname, mode, ncid)
+!          nfw_open(fname, mode, ncid)
+!          nfw_enddef(fname, ncid)
+!          nfw_close(fname, ncid)
+!          nfw_inq_unlimdim(fname, ncid, unlimdimid)
+!          nfw_inq_dimid(fname, ncid, name, dimid)
+!          nfw_inq_dimlen(fname, ncid, dimid, length)
+!          nfw_def_dim(fname, ncid, name, length, dimid)
+!          nfw_def_var(fname, ncid, name, type, ndims, dimids, varid)
+!          nfw_inq_varid(fname, ncid, name, varid)
+!          nfw_inq_varname(fname, ncid, varid, name)
+!          nfw_inq_varndims(fname, ncid, varid, ndims)
+!          nfw_inq_vardimid(fname, ncid, varid, dimids)
+!          nfw_rename_var(fname, ncid, oldname, newname)
+!          nfw_put_var_int(fname, ncid, varid, v)
+!          nfw_put_var_double(fname, ncid, varid, v)
+!          nfw_put_var_real(fname, ncid, varid, v)
+!          nfw_get_var_int(fname, ncid, varid, v)
+!          nfw_get_var_double(fname, ncid, varid, v)
+!          nfw_put_vara_int(fname, ncid, varid, start, length, v)
+!          nfw_put_vara_double(fname, ncid, varid, start, length, v)
+!          nfw_get_vara_int(fname, ncid, varid, start, length, v)
+!          nfw_get_vara_double(fname, ncid, varid, start, length, v)
+!          nfw_get_att_int(fname, ncid, varid, attname, v)
+!          nfw_get_att_real(fname, ncid, varid, attname, v)
+!          nfw_get_att_double(fname, ncid, varid, attname, v)
+!          nfw_put_att_text(fname, ncid, varid, attname, length, text)
+!          nfw_put_att_int(fname, ncid, varid, attname, type, length, v)
+!          nfw_put_att_real(fname, ncid, varid, attname, type, length, v)
+!          nfw_put_att_double(fname, ncid, varid, attname, type, length, v)
+!
+!          Derived procedures:
+!
+!          nfw_get_var_double_firstrecord(fname, ncid, varid, v)
+!          nfw_var_exists(ncid, name)
+!          nfw_dim_exists(ncid, name)
+! Modifications:
+!
+! 29/04/2008 PS: added nfw_rename_var(fname, ncid, oldname, newname)
+! 21/10/2009 PS: added nfw_var_exists(ncid, name)
+! 22/10/2009 PS: added nfw_put_att_double(fname, ncid, varid, attname, type, 
+!                                         length, v)
+! 06/11/2009 PS: added nfw_dim_exists(ncid, name)
+!                nfw_put_att_real(fname, ncid, varid, attname, type, length, v)
+!                nfw_get_att_real(fname, ncid, varid, attname, v)
+
+module nfw_mod
+  implicit none
+  include 'netcdf.inc'
+
+  character(*), private, parameter :: nfw_version = "0.03"
+  integer, private, parameter :: logunit = 6
+  character(*), private, parameter :: errprefix = "nfw: error: "
+  private quit1, quit2, quit3
+
+contains
+
+#if defined(F90_NOFLUSH)
+  subroutine flush(dummy)
+    integer, intent(in) :: dummy
+  end subroutine flush
+#endif
+
+  ! Common exit point -- for the sake of debugging
+  subroutine quit
+    stop
+  end subroutine quit
+
+  subroutine quit1(fname, procname, status)
+    character*(*), intent(in) :: fname
+    character*(*), intent(in) :: procname
+    integer, intent(in) :: status
+ 
+    write(logunit, *)
+    write(logunit, *) errprefix, '"', trim(fname), '": ', procname, '(): ',&
+         nf_strerror(status)
+    call flush(logunit)
+    call quit
+  end subroutine quit1
+
+  subroutine quit2(fname, procname, name, status)
+    character*(*), intent(in) :: fname
+    character*(*), intent(in) :: procname
+    character*(*), intent(in) :: name
+    integer, intent(in) :: status
+
+    write(logunit, *)
+    write(logunit, *) errprefix, '"', trim(fname), '": ', procname, '(): "',&
+         trim(name), '": ', nf_strerror(status)
+    call flush(logunit)
+    call quit
+  end subroutine quit2
+
+  subroutine quit3(fname, procname, name1, name2, status)
+    character*(*), intent(in) :: fname
+    character*(*), intent(in) :: procname
+    character*(*), intent(in) :: name1
+    character*(*), intent(in) :: name2
+    integer, intent(in) :: status
+
+    write(logunit, *)
+    write(logunit, *) errprefix, '"', trim(fname), '": ', procname, '(): "',&
+         trim(name1), '": "', trim(name2), '": ', nf_strerror(status)
+    call flush(logunit)
+    call quit
+  end subroutine quit3
+
+  subroutine nfw_create(fname, mode, ncid)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: mode
+    integer, intent(out) :: ncid
+
+    integer :: status
+
+    status = nf_create(trim(fname), mode, ncid)
+    if (status /= 0) call quit1(fname, 'nf_create', status)
+  end subroutine nfw_create
+
+  subroutine nfw_open(fname, mode, ncid)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: mode
+    integer, intent(out) :: ncid
+
+    integer :: status
+
+    status = nf_open(trim(fname), mode, ncid)
+    if (status /= 0) call quit1(fname, 'nf_open', status)
+  end subroutine nfw_open
+
+  subroutine nfw_enddef(fname, ncid)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+
+    integer :: status
+
+    status = nf_enddef(ncid)
+    if (status /= 0) call quit1(fname, 'nf_enddef', status)
+  end subroutine nfw_enddef
+
+  subroutine nfw_redef(fname, ncid)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+
+    integer :: status
+
+    status = nf_redef(ncid)
+    if (status /= 0) call quit1(fname, 'nf_redef', status)
+  end subroutine nfw_redef
+
+  subroutine nfw_close(fname, ncid)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+
+    integer :: status
+
+    status = nf_close(ncid)
+    if (status /= 0) call quit1(fname, 'nf_close', status)
+  end subroutine nfw_close
+
+  subroutine nfw_inq_unlimdim(fname, ncid, unlimdimid)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(out) :: unlimdimid
+
+    integer :: status
+    
+    status = nf_inq_unlimdim(ncid, unlimdimid)
+    if (status /= 0) call quit1(fname, 'nf_inq_unlimdimid', status)
+  end subroutine nfw_inq_unlimdim
+
+  subroutine nfw_inq_dimid(fname, ncid, name, dimid)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    character*(*), intent(in) :: name
+    integer, intent(out) :: dimid
+
+    integer :: status
+    
+    status = nf_inq_dimid(ncid, trim(name), dimid)
+    if (status /= 0) call quit2(fname, 'nf_inq_dimid', name, status)
+  end subroutine nfw_inq_dimid
+
+  subroutine nfw_inq_dimlen(fname, ncid, dimid, length)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: dimid
+    integer, intent(out) :: length
+
+    integer :: status
+
+    status = nf_inq_dimlen(ncid, dimid, length)
+    if (status /= 0) call quit1(fname, 'nf_inq_dimlen', status)
+  end subroutine nfw_inq_dimlen
+
+  subroutine nfw_def_dim(fname, ncid, name, length, dimid)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    character*(*), intent(in) :: name
+    integer, intent(in) :: length
+    integer, intent(out) :: dimid
+
+    integer :: status
+
+    status = nf_def_dim(ncid, name, length, dimid)
+    if (status /= 0) call quit2(fname, 'nf_def_dim', name, status)
+  end subroutine nfw_def_dim
+
+  subroutine nfw_def_var(fname, ncid, name, type, ndims, dimids, varid)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    character*(*), intent(in) :: name
+    integer, intent(in) :: type
+    integer, intent(in) :: ndims
+    integer, intent(in) :: dimids(*)
+    integer, intent(out) :: varid
+
+    integer :: status
+
+    status = nf_def_var(ncid, name, type, ndims, dimids, varid)
+    if (status /= 0) call quit2(fname, 'nf_def_var', name, status)
+  end subroutine nfw_def_var
+
+  subroutine nfw_inq_varid(fname, ncid, name, varid)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    character*(*), intent(in) :: name
+    integer, intent(out) :: varid
+
+    integer :: status
+   
+    status = nf_inq_varid(ncid, trim(name), varid)
+    if (status /= 0) call quit2(fname, 'nf_inq_varid', name, status)
+  end subroutine nfw_inq_varid
+
+  subroutine nfw_inq_varname(fname, ncid, varid, name)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    character*(*), intent(out) :: name
+
+    integer :: status
+
+    status = nf_inq_varname(ncid, varid, name)
+    if (status /= 0) call quit1(fname, 'nf_inq_varname', status)
+  end subroutine nfw_inq_varname
+
+  subroutine nfw_inq_varndims(fname, ncid, varid, ndims)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    integer, intent(out) :: ndims
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_inq_varndims(ncid, varid, ndims)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_inq_varndims', name, status)
+    end if
+  end subroutine nfw_inq_varndims
+
+  subroutine nfw_inq_vardimid(fname, ncid, varid, dimids)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    integer, intent(out) :: dimids(*)
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_inq_vardimid(ncid, varid, dimids)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_inq_vardimid', name, status)
+    end if
+  end subroutine nfw_inq_vardimid
+
+  subroutine nfw_rename_var(fname, ncid, oldname, newname)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    character*(*), intent(in) :: oldname
+    character*(*), intent(in) :: newname
+
+    integer :: varid
+    integer :: status
+
+    call nfw_inq_varid(fname, ncid, oldname, varid)
+    status = nf_rename_var(ncid, varid, newname)
+    if (status /= 0) then
+       call quit2(fname, 'nf_rename_var', oldname, status)
+    end if
+  end subroutine nfw_rename_var
+
+  subroutine nfw_put_var_int(fname, ncid, varid, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    integer, intent(in) :: v(*)
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_put_var_int(ncid, varid, v)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_put_var_double', name, status)
+    end if
+  end subroutine nfw_put_var_int
+
+  subroutine nfw_put_var_double(fname, ncid, varid, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    real(8), intent(in) :: v(*)
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_put_var_double(ncid, varid, v)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_put_var_double', name, status)
+    end if
+  end subroutine nfw_put_var_double
+
+  subroutine nfw_put_var_real(fname, ncid, varid, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    real(4), intent(in) :: v(*)
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_put_var_real(ncid, varid, v)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_put_var_real', name, status)
+    end if
+  end subroutine nfw_put_var_real
+
+  subroutine nfw_get_var_int(fname, ncid, varid, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    integer, intent(out) :: v(*)
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_get_var_int(ncid, varid, v)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_get_var_int', name, status)
+    end if
+  end subroutine nfw_get_var_int
+
+  subroutine nfw_get_var_double(fname, ncid, varid, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    real(8), intent(out) :: v(*)
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_get_var_double(ncid, varid, v)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_get_var_double', name, status)
+    end if
+  end subroutine nfw_get_var_double
+
+  subroutine nfw_get_var_text(fname, ncid, varid, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    character, intent(out) :: v(*)
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_get_var_text(ncid, varid, v)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_get_var_int', name, status)
+    end if
+  end subroutine nfw_get_var_text
+
+  subroutine nfw_put_vara_int(fname, ncid, varid, start, length, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    integer, intent(in) :: start(*)
+    integer, intent(in) :: length(*)
+    integer, intent(in) :: v(*)
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_put_vara_int(ncid, varid, start, length, v)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_put_vara_int', name, status)
+    end if
+  end subroutine nfw_put_vara_int
+
+  subroutine nfw_put_vara_double(fname, ncid, varid, start, length, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    integer, intent(in) :: start(*)
+    integer, intent(in) :: length(*)
+    real(8), intent(in) :: v(*)
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_put_vara_double(ncid, varid, start, length, v)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_put_vara_double', name, status)
+    end if
+  end subroutine nfw_put_vara_double
+
+  subroutine nfw_get_vara_int(fname, ncid, varid, start, length, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    integer, intent(in) :: start(*)
+    integer, intent(in) :: length(*)
+    integer, intent(out) :: v(*)
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_get_vara_int(ncid, varid, start, length, v)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_get_vara_int', name, status)
+    end if
+  end subroutine nfw_get_vara_int
+
+  subroutine nfw_get_vara_double(fname, ncid, varid, start, length, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    integer, intent(in) :: start(*)
+    integer, intent(in) :: length(*)
+    real(8), intent(out) :: v(*)
+
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    status = nf_get_vara_double(ncid, varid, start, length, v)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_get_vara_double', name, status)
+    end if
+  end subroutine nfw_get_vara_double
+
+  subroutine nfw_get_att_int(fname, ncid, varid, attname, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    character*(*), intent(in) :: attname
+    integer, intent(out) :: v(*)
+
+    character*(NF_MAX_NAME) :: varname
+    integer :: status
+
+    status = nf_get_att_int(ncid, varid, attname, v)
+    if (status /= 0) then
+       if (varid /= nf_global) then
+          call nfw_inq_varname(fname, ncid, varid, varname)
+       else
+          varname = 'NF_GLOBAL'
+       end if
+       call quit3(fname, 'nf_get_att_int', varname, attname, status)
+    end if
+  end subroutine nfw_get_att_int
+
+  subroutine nfw_get_att_real(fname, ncid, varid, attname, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    character*(*), intent(in) :: attname
+    real(4), intent(out) :: v(*)
+
+    character*(NF_MAX_NAME) :: varname
+    integer :: status
+
+    status = nf_get_att_real(ncid, varid, attname, v)
+    if (status /= 0) then
+       if (varid /= nf_global) then
+          call nfw_inq_varname(fname, ncid, varid, varname)
+       else
+          varname = 'NF_GLOBAL'
+       end if
+       call quit3(fname, 'nf_get_att_real', varname, attname, status)
+    end if
+  end subroutine nfw_get_att_real
+
+  subroutine nfw_get_att_double(fname, ncid, varid, attname, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    character*(*), intent(in) :: attname
+    real(8), intent(out) :: v(*)
+
+    character*(NF_MAX_NAME) :: varname
+    integer :: status
+
+    status = nf_get_att_double(ncid, varid, attname, v)
+    if (status /= 0) then
+       if (varid /= nf_global) then
+          call nfw_inq_varname(fname, ncid, varid, varname)
+       else
+          varname = 'NF_GLOBAL'
+       end if
+       call quit3(fname, 'nf_get_att_double', varname, attname, status)
+    end if
+  end subroutine nfw_get_att_double
+
+  subroutine nfw_put_att_text(fname, ncid, varid, attname, length, text)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    character*(*), intent(in) :: attname
+    integer, intent(in) :: length
+    character*(*), intent(in) :: text
+
+    integer :: status
+    character*(NF_MAX_NAME) :: varname
+
+    status = nf_put_att_text(ncid, varid, attname, length, trim(text))
+    if (status /= 0) then
+       if (varid /= nf_global) then
+          call nfw_inq_varname(fname, ncid, varid, varname)
+       else
+          varname = 'NF_GLOBAL'
+       end if
+       call quit3(fname, 'nf_put_att_text', varname, attname, status)
+    end if
+  end subroutine nfw_put_att_text
+
+  subroutine nfw_put_att_int(fname, ncid, varid, attname, type, length, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    character*(*), intent(in) :: attname
+    integer, intent(in) :: type
+    integer, intent(in) :: length
+    integer, intent(in) :: v(*)
+
+    integer :: status
+    character*(NF_MAX_NAME) :: varname
+
+    status = nf_put_att_int(ncid, varid, attname, type, length, v)
+    if (status /= 0) then
+       if (varid /= nf_global) then
+          call nfw_inq_varname(fname, ncid, varid, varname)
+       else
+          varname = 'NF_GLOBAL'
+       end if
+       call quit3(fname, 'nf_put_att_int', varname, attname, status)
+    end if
+  end subroutine nfw_put_att_int
+
+  subroutine nfw_put_att_real(fname, ncid, varid, attname, type, length, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    character*(*), intent(in) :: attname
+    integer, intent(in) :: type
+    integer, intent(in) :: length
+    real(4), intent(in) :: v(*)
+
+    integer :: status
+    character*(NF_MAX_NAME) :: varname
+
+    status = nf_put_att_real(ncid, varid, attname, type, length, v)
+    if (status /= 0) then
+       if (varid /= nf_global) then
+          call nfw_inq_varname(fname, ncid, varid, varname)
+       else
+          varname = 'NF_GLOBAL'
+       end if
+       call quit3(fname, 'nf_put_att_real', varname, attname, status)
+    end if
+  end subroutine nfw_put_att_real
+
+  subroutine nfw_put_att_double(fname, ncid, varid, attname, type, length, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    character*(*), intent(in) :: attname
+    integer, intent(in) :: type
+    integer, intent(in) :: length
+    real(8), intent(in) :: v(*)
+
+    integer :: status
+    character*(NF_MAX_NAME) :: varname
+
+    status = nf_put_att_double(ncid, varid, attname, type, length, v)
+    if (status /= 0) then
+       if (varid /= nf_global) then
+          call nfw_inq_varname(fname, ncid, varid, varname)
+       else
+          varname = 'NF_GLOBAL'
+       end if
+       call quit3(fname, 'nf_put_att_double', varname, attname, status)
+    end if
+  end subroutine nfw_put_att_double
+
+! Derived subroutines
+
+  ! Reads the first record only
+  subroutine nfw_get_var_double_firstrecord(fname, ncid, varid, v)
+    character*(*), intent(in) :: fname
+    integer, intent(in) :: ncid
+    integer, intent(in) :: varid
+    real(8), intent(out) :: v(*)
+
+    integer :: ndims
+    integer :: unlimdimid
+    integer :: dimids(NF_MAX_VAR_DIMS)
+    integer :: dimlen(NF_MAX_VAR_DIMS)
+    integer :: dstart(NF_MAX_VAR_DIMS)
+    integer :: i
+    character*(NF_MAX_NAME) :: name
+    integer :: status
+
+    call nfw_inq_varndims(fname, ncid, varid, ndims)
+    call nfw_inq_vardimid(fname, ncid, varid, dimids)
+    call nfw_inq_unlimdim(fname, ncid, unlimdimid)
+    
+    do i = 1, ndims
+       call nfw_inq_dimlen(fname, ncid, dimids(i), dimlen(i))
+       dstart(i) = 1
+    end do
+
+    ! check size of v
+    if (dimids(ndims) == unlimdimid) then
+       dimlen(ndims) = 1 ! 1 record only
+    end if
+
+    status = nf_get_vara_double(ncid, varid, dstart, dimlen, v)
+    if (status /= 0) then
+       call nfw_inq_varname(fname, ncid, varid, name)
+       call quit2(fname, 'nf_get_vara_double', name, status)
+    end if
+  end subroutine nfw_get_var_double_firstrecord
+
+  logical function nfw_var_exists(ncid, name)
+    integer, intent(in) :: ncid
+    character*(*), intent(in) :: name
+
+    integer :: varid
+    integer :: status
+
+    status = nf_inq_varid(ncid, trim(name), varid)
+    nfw_var_exists = (status == 0)
+  end function nfw_var_exists
+
+  logical function nfw_dim_exists(ncid, name)
+    integer, intent(in) :: ncid
+    character*(*), intent(in) :: name
+
+    integer :: dimid
+    integer :: status
+
+    status = nf_inq_dimid(ncid, trim(name), dimid)
+    nfw_dim_exists = (status == 0)
+  end function nfw_dim_exists
+
+end module nfw_mod

EnKF-MPI-TOPAZ/order.c

@@ -0,0 +1,110 @@
+/* File:          order.c
+ *
+ * Created:       2 Mar 2008
+ *
+ * Last modified: 2 Mar 2008
+ * Author:        Pavel Sakov
+ *                NERSC
+ *
+ * Purpose:       Put indices of an array of double in an order of increasing
+ *                value.
+ *
+ * Description:   Given a double array x[n], sort its subset specified by an
+ *                integer array of indices good[ngood] and return the indices
+ *                of sorted elements in the integer array inorder[ngood].
+ *                
+ *                It is assumed that good[ngood] stores the "fortran" indices
+ *                (from 1 to N rather than from 0 to N - 1).
+ *
+ * Modifications: none
+ */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include "cfortran.h"
+
+typedef struct {
+    int index;
+    double v;
+} indexedvalue;
+
+static int comp(const void* p1, const void* p2)
+{
+    indexedvalue* v1 = (indexedvalue*) p1;
+    indexedvalue* v2 = (indexedvalue*) p2;
+
+    if (v1->v > v2->v)
+	return 1;
+    else if (v1->v < v2->v)
+	return -1;
+    return 0;
+}
+
+/** Sorts a specified subset within an array of double according to values.
+ *
+ * Given a double array x[n], sorts its subset specified by an integer array
+ * good[ngood] and returns the indices of sorted elements in the preallocated
+ * integer array inorder[ngood].
+ *
+ * It is assumed that good[ngood] stores the "fortran" indices (from 1 to N
+ * rather than from 0 to N - 1).
+ *
+ * @param pn Number of elements in the data array
+ * @param x Data array
+ * @param pngood Number of elements in the data array to be sorted
+ * @param good Indices of the elements in the data array to be sorted
+ * @param inorder Output array of size of `ngood' such that the corresponding
+ *                elements of the data array are in increasing order
+ */
+void order(double pn[], double x[], double pngood[], int good[], int inorder[])
+{
+    int n = (int) pn[0];
+    int ngood = (int) pngood[0];
+    indexedvalue* iv = NULL;
+    int i;
+    
+    if (n <= 0) {
+	for (i = 0; i < ngood; ++i)
+	    inorder[i] = -1;
+	return;
+    }
+
+    iv = malloc(n * sizeof(indexedvalue));
+    if (n < ngood) {
+	fprintf(stderr, "ERROR: order.c: order(): size of the data = %d is less than the requested size of the sorted array %d\n", n, ngood);
+	exit(1);
+    }
+
+    /*
+     * a bit of quality control
+     */
+    for (i = 0; i < ngood; ++i) {
+	double xx;
+
+	if (good[i] < 1 || good[i] > n) {
+	    fprintf(stderr, "ERROR: order.c: order(): good[%d] = %d, n = %d\n", i, good[i], n);
+	    exit(1);
+	}
+	xx = x[good[i] - 1];
+	if (isnan(xx) || fabs(xx) > 1.0e+10 || xx == -999.0) {
+	    fprintf(stderr, "ERROR: order.c: order(): x[%d] = %.15g\n", good[i] - 1, xx);
+	    exit(1);
+	}
+    }
+
+    for (i = 0; i < ngood; ++i) {
+	iv[i].index = good[i];
+	iv[i].v = x[good[i] - 1];
+    }
+
+    qsort(iv, ngood, sizeof(indexedvalue), comp);
+
+    for (i = 0; i < ngood; ++i)
+	inorder[i] = iv[i].index;
+
+    free(iv);
+}
+
+FCALLSCSUB5(order, ORDER, order, PDOUBLE, PDOUBLE, PDOUBLE, PINT, PINT)

EnKF-MPI-TOPAZ/qmpi.F90

@@ -0,0 +1,2072 @@
+#if defined(QMPI)
+module qmpi
+!
+! A module defining a minimalist interface to a subset of MPI.
+! The first five primitives can in theory be used to parallelize
+! any program. The module hides type specification, communicators,
+! explicit error handling, the need to give explicit buffer size etc.
+! Also provided are a few interfaces for often used broadcast and 
+! reduction operations
+!
+! © Helge Avlesen <avle@ii.uib.no>, para//ab
+!
+! primitives: (optional arguments in brackets)
+!
+!   subroutine start_mpi()
+!      starts the mpi subsystem. all processesors are assigned a number (myid).
+!      the number of processors is numproc.
+!   subroutine stop_mpi()
+!      stops the mpi subsystem
+!   subroutine barrier([label])
+!      syncronization point for all processors. optionally prints a label on
+!      the master processor (0).
+!   subroutine send(data, target [,tag])
+!      send object data to processor number target, tag is an optional integer
+!      that defaults to 0. (if multiple messages are exchanged between a
+!      pair of processors, a unique tag must be used for each exhange)
+!   subroutine receive(data, source [,tag])
+!      get object data from processor source, tag is optional and as for send
+!      MPI will fail if the size of the object received is different from what
+!      was sent.
+!  
+! The rest of the routines are included for convenience, they can be
+! also be implemented using the above subroutines.
+!
+!   subroutine broadcast(data [,root])
+!      broadcast data (any type) from processor root (default=0) to all
+!      other processors.
+!   subroutine mbroadcast(data [,data2,data3,data4,data5,data6] [,root])
+!      broadcast up to 6 scalar variables of the same type, to all processors
+!      from processor root (default=0)
+!   subroutine reduce(type, data [,data2,data3,data4,data5,data6] [,root] )
+!      reduce the scalar data, optionally also data2-data6, return result
+!      on all processes. the operation can currently be of type 'sum', 'mul',
+!      'min' or 'max' i.e. a sum or a product. data-data6 must be of the 
+!      same type. if integer root is present, only return result on that 
+!      processor (faster)
+!
+! Example: a program that sends a real from processor 0 to processor 1
+!   use qmpi
+!   real data
+!   call start_mpi
+!   data=myid
+!   if(myid==0) call send(data, 1)
+!   if(myid==1) then
+!      call receive(data, 0)
+!      print *,'hello, I am',myid,'got ',data,'from process 0'
+!   end if
+!   call stop_mpi
+!   end
+!
+! More advanced usage example: to send a derived type from 0 to 1; 
+! pack it in a string (could be packed into any array), send, receive, unpack.
+! 
+! type(any_type) var1
+! character, allocatable :: buffer(:)
+! ...
+! N=size(transfer(var1,(/'x'/))))   !! compute size of type once
+! allocate(buffer(N))
+! if(myid==0)then
+!     buffer = transfer(var1,buffer)
+!     call send(buffer,1)
+! end if
+! if(myid==1)then
+!     call receive(buffer,0)
+!     var1 = transfer(buffer,var1)
+! end if
+! ...
+!  
+#warning "COMPILING WITH QMPI CODE"
+  include 'mpif.h'
+  integer, public :: qmpi_proc_num, qmpi_num_proc, ierr, errorcode, mpistatus(mpi_status_size)
+  logical, public :: master=.false., slave=.false.
+
+! some kinds. could use selected_real_kind(..) for this instead of hard coding
+  integer, parameter :: dp=8, sp=4, long=8, short=2
+
+  interface send
+     module procedure            &
+          qmpi_send_real4,       &
+          qmpi_send_real4_1d,    &
+          qmpi_send_real4_2d,    &
+          qmpi_send_real4_3d,    &
+          qmpi_send_real4_4d,    &
+          qmpi_send_real8,       &
+          qmpi_send_real8_1d,    &
+          qmpi_send_real8_2d,    &
+          qmpi_send_real8_3d,    &
+          qmpi_send_real8_4d,    &
+          qmpi_send_integer4,    &
+          qmpi_send_integer4_1d, &
+          qmpi_send_integer4_2d, &
+          qmpi_send_integer4_3d, &
+          qmpi_send_integer4_4d, &
+          qmpi_send_integer8,    &
+          qmpi_send_integer8_1d, &
+          qmpi_send_integer8_2d, &
+          qmpi_send_integer8_3d, &
+          qmpi_send_integer8_4d, &
+          qmpi_send_string,      &
+          qmpi_send_character_1d,&
+          qmpi_send_logical
+  end interface
+
+  interface receive
+     module procedure &
+          qmpi_recv_real4,       &
+          qmpi_recv_real4_1d,    &
+          qmpi_recv_real4_2d,    &
+          qmpi_recv_real4_3d,    &
+          qmpi_recv_real4_4d,    &
+          qmpi_recv_real8,       &
+          qmpi_recv_real8_1d,    &
+          qmpi_recv_real8_2d,    &
+          qmpi_recv_real8_3d,    &
+          qmpi_recv_real8_4d,    &
+          qmpi_recv_integer4,    & 
+          qmpi_recv_integer4_1d, &
+          qmpi_recv_integer4_2d, &
+          qmpi_recv_integer4_3d, &
+          qmpi_recv_integer4_4d, &
+          qmpi_recv_integer8,    &
+          qmpi_recv_integer8_1d, &
+          qmpi_recv_integer8_2d, &
+          qmpi_recv_integer8_3d, &
+          qmpi_recv_integer8_4d, &
+          qmpi_recv_string,      &
+          qmpi_recv_character_1d,&
+          qmpi_recv_logical
+  end interface
+
+  interface reduce
+     module procedure &
+          qmpi_integer_reduction, &
+          qmpi_integer8_reduction,&
+          qmpi_real_reduction,    &
+          qmpi_real8_reduction
+  end interface
+
+  interface broadcast
+     module procedure &
+          qmpi_broadcast_logical,  &
+          qmpi_broadcast_string,   &
+          qmpi_broadcast_stringarr,&
+          qmpi_broadcast_integer4, &
+          qmpi_broadcast_integer4_array1d,  &
+          qmpi_broadcast_integer4_array2d,  &
+          qmpi_broadcast_integer8, &
+          qmpi_broadcast_integer8_array1d, &
+          qmpi_broadcast_integer8_array2d, &
+          qmpi_broadcast_real4, &
+          qmpi_broadcast_real4_array1d, &
+          qmpi_broadcast_real4_array2d, &
+          qmpi_broadcast_real4_array3d, &
+          qmpi_broadcast_real4_array4d, &
+          qmpi_broadcast_real8, &
+          qmpi_broadcast_real8_array1d, &
+          qmpi_broadcast_real8_array2d, &
+          qmpi_broadcast_real8_array3d, &
+          qmpi_broadcast_real8_array4d
+  end interface
+
+  interface mbroadcast
+     module procedure &
+          qmpi_broadcast_logicals, &
+          qmpi_broadcast_real4s, &
+          qmpi_broadcast_real8s, &
+          qmpi_broadcast_integer4s, &
+          qmpi_broadcast_integer8s
+  end interface
+
+contains
+
+  subroutine start_mpi()
+!
+! initialize the core MPI subsystem
+! this routine should be called as the first statement in the program.
+! MPI does not specify what happen before MPI_init and after mpi_finalize
+!
+    implicit none
+
+    call mpi_init(ierr)
+    call mpi_comm_size(mpi_comm_world, qmpi_num_proc, ierr)
+    call mpi_comm_rank(mpi_comm_world, qmpi_proc_num, ierr)
+
+    master=.false.
+    if(qmpi_proc_num==0) master=.true.
+    if(qmpi_proc_num>0) slave=.true.
+print*,'Inne i start_mpi: qmpi_proc_num =',qmpi_proc_num,' master =',master
+
+    if(master) then
+        write(*,'(a,i0,a)') 'MPI started with ',qmpi_num_proc,' processors'
+    end if
+  end subroutine start_mpi
+
+  subroutine stop_mpi()
+    implicit none
+    call mpi_finalize(ierr)
+    stop
+  end subroutine stop_mpi
+
+  subroutine barrier(label)
+! makes all processes sync at this point, optionally print a label
+    implicit none
+    character(*), optional :: label
+    call mpi_barrier(mpi_comm_world, ierr)
+    if(master.and.present(label)) print *,'---barrier---',label,'---------'
+  end subroutine barrier
+
+  subroutine qmpi_send_logical(data, target, tag)
+    implicit none
+    logical data
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=1
+    call mpi_send(data, counter, mpi_logical, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_logical count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_logical
+
+  subroutine qmpi_send_string(data, target, tag)
+    implicit none
+    character(*) data
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=len(data)
+    call mpi_send(data, counter, mpi_character, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_string count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_string
+
+  subroutine qmpi_send_character_1d(data, target, tag)
+    implicit none
+    character data(:)
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data)
+    call mpi_send(data, counter, mpi_character, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_character_1d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_character_1d
+  
+  subroutine qmpi_recv_character_1d(data, target, tag)
+    implicit none
+    character data(:)
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data)
+    call mpi_recv(data, counter, mpi_character, target, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_character_1d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_character_1d
+    
+  subroutine qmpi_send_integer4(data, target, tag)
+    implicit none
+    integer(sp) data
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=1
+    call mpi_send(data, counter, mpi_integer, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_integer4 count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_integer4
+
+  subroutine qmpi_send_integer4_1d(data, target, tag)
+    implicit none
+    integer(sp) data(:)
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data)
+    call mpi_send(data, counter, mpi_integer, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_integer4_1d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_integer4_1d
+
+  subroutine qmpi_send_integer4_2d(data, target, tag)
+    implicit none
+    integer(sp) data(:,:)
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)
+    call mpi_send(data, counter, mpi_integer, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_integer4_2d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_integer4_2d
+
+  subroutine qmpi_send_integer4_3d(data, target, tag)
+    implicit none
+    integer(sp) data(:,:,:)
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)
+    call mpi_send(data, counter, mpi_integer, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_integer4_3d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_integer4_3d
+
+  subroutine qmpi_send_integer4_4d(data, target, tag)
+    implicit none
+    integer(sp) data(:,:,:,:)
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)*size(data,4)
+    call mpi_send(data, counter, mpi_integer, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_integer4_4d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_integer4_4d
+
+  subroutine qmpi_send_integer8(data, target, tag)
+    implicit none
+    integer(long) data
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=1
+    call mpi_send(data, counter, mpi_integer8, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_integer8 count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_integer8
+
+  subroutine qmpi_send_integer8_1d(data, target, tag)
+    implicit none
+    integer(long) data(:)
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data)
+    call mpi_send(data, counter, mpi_integer8, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_integer8_1d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_integer8_1d
+
+  subroutine qmpi_send_integer8_2d(data, target, tag)
+    implicit none
+    integer(long) data(:,:)
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)
+    call mpi_send(data, counter, mpi_integer8, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_integer8_2d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_integer8_2d
+
+  subroutine qmpi_send_integer8_3d(data, target, tag)
+    implicit none
+    integer(8) data(:,:,:)
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)
+    call mpi_send(data, counter, mpi_integer8, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_integer8_3d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_integer8_3d
+
+  subroutine qmpi_send_integer8_4d(data, target, tag)
+    implicit none
+    integer(8) data(:,:,:,:)
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)*size(data,4)
+    call mpi_send(data, counter, mpi_integer8, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_integer8_4d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_integer8_4d
+
+  subroutine qmpi_send_real4(data, target, tag)
+    implicit none
+    real(sp) data
+    integer target
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=1
+    call mpi_send(data, counter, mpi_real, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_real4 count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_real4
+
+  subroutine qmpi_send_real8(data, target, tag)
+    implicit none
+    real(dp) data
+    integer target
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=1
+    call mpi_send(data, counter, mpi_double_precision, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_real8 count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_real8
+
+  subroutine qmpi_send_real4_1d(data, target, tag)
+    implicit none
+    real(sp) data(:)
+    integer target
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data)
+    call mpi_send(data, counter, mpi_real, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_real4_1d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_real4_1d
+
+  subroutine qmpi_send_real8_1d(data, target, tag)
+    implicit none
+    real(dp) data(:)
+    integer target
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data)
+    call mpi_send(data, counter, mpi_double_precision, target, given_tag, mpi_comm_world, ierr)
+    if(ierr.ne.0)then
+        print *,'error send_real8_1d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_real8_1d
+
+  subroutine qmpi_send_real4_2d(data, target, tag)
+    implicit none
+    real(sp) data(:,:)
+    integer target
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)
+
+    call mpi_send(data, counter, mpi_real, target, given_tag, mpi_comm_world, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error send_real4_2d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_real4_2d
+
+  subroutine qmpi_send_real8_2d(data, target, tag)
+    implicit none
+    real(dp) data(:,:)
+    integer target
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)
+
+    call mpi_send(data, counter, mpi_double_precision, target, given_tag, mpi_comm_world, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error send_real8_2d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_real8_2d
+
+  subroutine qmpi_send_real4_3d(data, target, tag)
+    implicit none
+    real(sp) data(:,:,:)
+    integer target
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)
+
+    call mpi_send(data, counter, mpi_real, target, given_tag, mpi_comm_world, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error send_real4_3d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_real4_3d
+
+  subroutine qmpi_send_real8_3d(data, target, tag)
+    implicit none
+    real(dp) data(:,:,:)
+    integer target
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)
+
+    call mpi_send(data, counter, mpi_double_precision, target, given_tag, mpi_comm_world, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error send_real8_3d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_real8_3d
+
+  subroutine qmpi_send_real4_4d(data, target, tag)
+    implicit none
+    real(sp) data(:,:,:,:)
+    integer target
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)*size(data,4)
+
+    call mpi_send(data, counter, mpi_real, target, given_tag, mpi_comm_world, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error send_real4_4d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_real4_4d
+
+  subroutine qmpi_send_real8_4d(data, target, tag)
+    implicit none
+    real(dp) data(:,:,:,:)
+    integer target
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)*size(data,4)
+
+    call mpi_send(data, counter, mpi_double_precision, target, given_tag, mpi_comm_world, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error send_real8_4d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_send_real8_4d
+
+  subroutine qmpi_recv_integer4(data, source, tag)
+    implicit none
+    integer(sp) data
+    integer source, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=1
+    call mpi_recv(data, counter, mpi_integer, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_integer4_1d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_integer4
+
+  subroutine qmpi_recv_integer4_1d(data, source, tag)
+    implicit none
+    integer(sp) data(:)
+    integer source, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data)
+    call mpi_recv(data, counter, mpi_integer, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_integer4_1d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_integer4_1d
+
+  subroutine qmpi_recv_integer4_2d(data, source, tag)
+    implicit none
+    integer(sp) data(:,:)
+    integer source, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)
+    call mpi_recv(data, counter, mpi_integer, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_integer4_2d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_integer4_2d
+
+  subroutine qmpi_recv_integer4_3d(data, source, tag)
+    implicit none
+    integer(sp) data(:,:,:)
+    integer source, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)
+    call mpi_recv(data, counter, mpi_integer, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_integer4_3d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_integer4_3d
+
+  subroutine qmpi_recv_integer4_4d(data, source, tag)
+    implicit none
+    integer(sp) data(:,:,:,:)
+    integer source, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)*size(data,4)
+    call mpi_recv(data, counter, mpi_integer, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_integer4_4d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_integer4_4d
+
+  subroutine qmpi_recv_integer8(data, source, tag)
+    implicit none
+    integer(long) data
+    integer source, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=1
+    call mpi_recv(data, counter, mpi_integer8, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_integer8 count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_integer8
+
+  subroutine qmpi_recv_integer8_1d(data, source, tag)
+    implicit none
+    integer(long) data(:)
+    integer source, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data)
+    call mpi_recv(data, counter, mpi_integer8, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_integer8_1d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_integer8_1d
+
+  subroutine qmpi_recv_integer8_2d(data, source, tag)
+    implicit none
+    integer(long) data(:,:)
+    integer source, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)
+    call mpi_recv(data, counter, mpi_integer8, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_integer8_2d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_integer8_2d
+
+  subroutine qmpi_recv_integer8_3d(data, source, tag)
+    implicit none
+    integer(8) data(:,:,:)
+    integer source, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)
+    call mpi_recv(data, counter, mpi_integer8, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_integer8_3d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_integer8_3d
+
+  subroutine qmpi_recv_integer8_4d(data, source, tag)
+    implicit none
+    integer(8) data(:,:,:,:)
+    integer source, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)*size(data,4)
+    call mpi_recv(data, counter, mpi_integer8, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_integer8_4d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_integer8_4d
+
+  subroutine qmpi_recv_real4(data, source, tag)
+    implicit none
+    real(sp) data
+    integer source
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=1
+    call mpi_recv(data, counter, mpi_real, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_real4 count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_real4
+
+  subroutine qmpi_recv_real8(data, source, tag)
+    implicit none
+    real(dp) data
+    integer source
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=1
+    call mpi_recv(data, counter, mpi_double_precision, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_real8 count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_real8
+
+  subroutine qmpi_recv_real4_1d(data, source, tag)
+    implicit none
+    real(sp) data(:)
+    integer source
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data)
+    call mpi_recv(data, counter, mpi_real, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_real4_1d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_real4_1d
+
+  subroutine qmpi_recv_real8_1d(data, source, tag)
+    implicit none
+    real(dp) data(:)
+    integer source
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data)
+    call mpi_recv(data, counter, mpi_double_precision, source, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_real8_1d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_real8_1d
+
+  subroutine qmpi_recv_real4_2d(data, source, tag)
+    implicit none
+    real(sp) data(:,:)
+    integer source
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)
+
+    call mpi_recv(data, counter, mpi_real, source, given_tag, mpi_comm_world, mpistatus, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error recv_real4_2d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_real4_2d
+
+  subroutine qmpi_recv_real8_2d(data, source, tag)
+    implicit none
+    real(dp) data(:,:)
+    integer source
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)
+
+    call mpi_recv(data, counter, mpi_double_precision, source, given_tag, mpi_comm_world, mpistatus, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error recv_real8_2d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_real8_2d
+
+  subroutine qmpi_recv_real4_3d(data, source, tag)
+    implicit none
+    real(sp) data(:,:,:)
+    integer source
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)
+
+    call mpi_recv(data, counter, mpi_real, source, given_tag, mpi_comm_world, mpistatus, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error recv_real4_3d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_real4_3d
+
+  subroutine qmpi_recv_real8_3d(data, source, tag)
+    implicit none
+    real(dp) data(:,:,:)
+    integer source
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)
+
+    call mpi_recv(data, counter, mpi_double_precision, source, given_tag, mpi_comm_world, mpistatus, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error recv_real8_3d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_real8_3d
+
+  subroutine qmpi_recv_real4_4d(data, source, tag)
+    implicit none
+    real(sp) data(:,:,:,:)
+    integer source
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)*size(data,4)
+
+    call mpi_recv(data, counter, mpi_real, source, given_tag, mpi_comm_world, mpistatus, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error recv_real4_4d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_real4_4d
+
+  subroutine qmpi_recv_real8_4d(data, source, tag)
+    implicit none
+    real(dp) data(:,:,:,:)
+    integer source
+    integer, optional :: tag
+    integer counter, given_tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=size(data,1)*size(data,2)*size(data,3)*size(data,4)
+
+    call mpi_recv(data, counter, mpi_double_precision, source, given_tag, mpi_comm_world, mpistatus, ierr)
+
+    if(ierr.ne.0)then
+        print *,'error recv_real8_4d count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_real8_4d
+
+  subroutine qmpi_recv_logical(data, target, tag)
+    implicit none
+    logical data
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=1
+    call mpi_recv(data, counter, mpi_logical, target, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_logical count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_logical
+
+  subroutine qmpi_recv_string(data, target, tag)
+    implicit none
+    character(*) data
+    integer target, counter, given_tag
+    integer, optional :: tag
+
+    given_tag=0
+    if(present(tag)) given_tag=tag
+    counter=len(data)
+    call mpi_recv(data, counter, mpi_character, target, given_tag, mpi_comm_world, mpistatus, ierr)
+    if(ierr.ne.0)then
+        print *,'error recv_string count=',counter,'tag=',given_tag
+        stop
+    end if
+  end subroutine qmpi_recv_string
+
+  subroutine qmpi_broadcast_string(string,root)
+!
+! send string out to all processes. if not given
+! process 0 will be used as the sender - root otherwise.
+!
+    implicit none
+    character(len=*) string
+    integer, optional :: root
+    integer counter,boss
+
+    counter=len(string)
+
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+
+    call mpi_bcast(string , counter, mpi_character, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_string
+
+  subroutine qmpi_broadcast_stringarr(data,root)
+    implicit none
+    character(len=*) data(:)
+    integer, optional :: root
+    integer counter, boss
+
+    counter=len(data(1))*size(data)
+
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+
+    call mpi_bcast(data, counter, mpi_character, boss, mpi_comm_world ,ierr)
+  end subroutine qmpi_broadcast_stringarr
+
+  subroutine qmpi_broadcast_real4(data,root)
+    implicit none
+    real(4) data
+    integer, optional :: root
+    integer counter,boss
+
+    counter=1
+    boss=0
+    if(present(root)) boss=root
+    call mpi_bcast(data , counter, mpi_real, boss, mpi_comm_world, ierr)
+  end subroutine qmpi_broadcast_real4
+
+  subroutine qmpi_broadcast_real8(data,root)
+    implicit none
+    real(8) data
+    integer, optional :: root
+    integer counter,boss
+
+    counter=1
+    boss=0
+    if(present(root)) boss=root
+    call mpi_bcast(data , counter, mpi_double_precision, boss, mpi_comm_world, ierr)
+  end subroutine qmpi_broadcast_real8
+
+  subroutine qmpi_broadcast_integer4(data,root)
+    implicit none
+    integer(4) data
+    integer, optional :: root
+    integer counter,boss
+
+    counter=1
+    boss=0
+    if(present(root)) boss=root
+    call mpi_bcast(data , counter, mpi_integer, boss, mpi_comm_world, ierr)
+  end subroutine qmpi_broadcast_integer4
+
+  subroutine qmpi_broadcast_integer8(data,root)
+    implicit none
+    integer(8) data
+    integer, optional :: root
+    integer counter,boss
+
+    counter=1
+    boss=0
+    if(present(root)) boss=root
+    call mpi_bcast(data , counter, mpi_integer8, boss, mpi_comm_world, ierr)
+  end subroutine qmpi_broadcast_integer8
+
+  subroutine qmpi_broadcast_logical(data, root)
+    implicit none
+    logical data
+    integer, optional :: root
+    integer counter,boss
+
+    counter=1
+    boss=0
+    if(present(root)) boss=root
+    call mpi_bcast(data , counter, mpi_logical, boss, mpi_comm_world, ierr)
+  end subroutine qmpi_broadcast_logical
+
+
+  subroutine qmpi_broadcast_integer4_array1d(data,root)
+    implicit none
+    integer(sp) data(:)
+    integer, optional :: root
+    integer counter,boss
+
+    counter=size(data)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data , counter, mpi_integer, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_integer4_array1d
+  
+  subroutine qmpi_broadcast_integer8_array1d(data,root)
+    implicit none
+    integer(long) data(:)
+    integer, optional :: root
+    integer counter,boss
+
+    counter=size(data)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data , counter, mpi_integer8, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_integer8_array1d
+
+  subroutine qmpi_broadcast_integer4_array2d(data,root)
+    implicit none
+    integer(sp) data(:,:)
+    integer, optional :: root
+    integer counter,boss
+
+    counter=size(data,1)*size(data,2)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data , counter, mpi_integer, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_integer4_array2d
+    
+  subroutine qmpi_broadcast_integer8_array2d(data,root)
+    implicit none
+    integer(long) data(:,:)
+    integer, optional :: root
+    integer counter,boss
+
+    counter=size(data,1)*size(data,2)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data , counter, mpi_integer8, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_integer8_array2d
+
+  subroutine qmpi_broadcast_real4_array1d(data,root)
+    implicit none
+    real(sp) data(:)
+    integer, optional :: root
+    integer counter, boss
+
+    counter=size(data)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data , counter, mpi_real, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_real4_array1d
+
+  subroutine qmpi_broadcast_real8_array1d(data,root)
+    implicit none
+    real(dp) data(:)
+    integer, optional :: root
+    integer counter, boss
+
+    counter=size(data)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data , counter, mpi_double_precision, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_real8_array1d
+
+  subroutine qmpi_broadcast_real4_array2d(data,root)
+    implicit none
+    real(sp) data(:,:)
+    integer, optional :: root
+    integer counter, boss
+
+    counter=size(data,1)*size(data,2)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data, counter, mpi_real, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_real4_array2d
+
+  subroutine qmpi_broadcast_real8_array2d(data,root)
+    implicit none
+    real(dp) data(:,:)
+    integer, optional :: root
+    integer counter, boss
+
+    counter=size(data,1)*size(data,2)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data, counter, mpi_double_precision, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_real8_array2d
+
+  subroutine qmpi_broadcast_real4_array3d(data,root)
+    implicit none
+    real(sp) data(:,:,:)
+    integer, optional :: root
+    integer counter, boss
+
+    counter=size(data,1)*size(data,2)*size(data,3)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data , counter, mpi_real, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_real4_array3d
+
+  subroutine qmpi_broadcast_real8_array3d(data,root)
+    implicit none
+    real(dp) data(:,:,:)
+    integer, optional :: root
+    integer counter, boss
+
+    counter=size(data,1)*size(data,2)*size(data,3)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data , counter, mpi_double_precision, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_real8_array3d
+
+  subroutine qmpi_broadcast_real4_array4d(data,root)
+    implicit none
+    real(sp) data(:,:,:,:)
+    integer, optional :: root
+    integer counter, boss
+
+    counter=size(data,1)*size(data,2)*size(data,3)*size(data,4)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data , counter, mpi_real, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_real4_array4d
+
+  subroutine qmpi_broadcast_real8_array4d(data,root)
+    implicit none
+    real(dp) data(:,:,:,:)
+    integer, optional :: root
+    integer counter, boss
+
+    counter=size(data,1)*size(data,2)*size(data,3)*size(data,4)
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    call mpi_bcast(data , counter, mpi_double_precision, boss, mpi_comm_world  ,ierr)
+  end subroutine qmpi_broadcast_real8_array4d
+
+  subroutine qmpi_broadcast_real4s(a,b,c,d,e,f,root)
+!
+! send a,b,c,d,e,f out to all processes. if not given
+! process 0 will be used as the sender - root otherwise.
+!
+    implicit none
+    real(sp) a
+    real(sp), optional :: b,c,d,e,f
+    integer, optional :: root
+    integer counter,boss
+    real(sp) rbuff(6)
+
+    counter=0   ;  boss=0
+    if(present(root)) then
+        boss=root
+    end if
+!    if(present(a)) then
+        counter=counter+1
+        rbuff(counter)=a
+!    end if
+    if(present(b)) then
+        counter=counter+1
+        rbuff(counter)=b
+    end if
+    if(present(c)) then
+        counter=counter+1
+        rbuff(counter)=c
+    end if
+    if(present(d)) then
+        counter=counter+1
+        rbuff(counter)=d
+    end if
+    if(present(e)) then
+        counter=counter+1
+        rbuff(counter)=e
+    end if
+    if(present(f)) then
+        counter=counter+1
+        rbuff(counter)=f
+    end if
+
+    call mpi_bcast(rbuff , counter, mpi_real, boss, mpi_comm_world  ,ierr)
+
+    counter=1
+    a=rbuff(counter)
+    if(present(b)) then
+        counter=counter+1
+        b=rbuff(counter)
+    end if
+    if(present(c)) then
+        counter=counter+1
+        c=rbuff(counter)
+    end if
+    if(present(d)) then
+        counter=counter+1
+        d=rbuff(counter)
+    end if
+    if(present(e)) then
+        counter=counter+1
+        e=rbuff(counter)
+    end if
+    if(present(f)) then
+        counter=counter+1
+        f=rbuff(counter)
+    end if
+  end subroutine qmpi_broadcast_real4s
+
+  subroutine qmpi_broadcast_real8s(a,b,c,d,e,f,root)
+!
+! send a,b,c,d,e,f out to all processes. if not given
+! process 0 will be used as the sender - root otherwise.
+!
+    implicit none
+    real(dp) a
+    real(dp), optional :: b,c,d,e,f
+    integer, optional :: root
+    integer counter,boss
+    real(kind=8) rbuff(6)
+
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+    counter=1
+    rbuff(counter)=a
+    if(present(b)) then
+        counter=counter+1
+        rbuff(counter)=b
+    end if
+    if(present(c)) then
+        counter=counter+1
+        rbuff(counter)=c
+    end if
+    if(present(d)) then
+        counter=counter+1
+        rbuff(counter)=d
+    end if
+    if(present(e)) then
+        counter=counter+1
+        rbuff(counter)=e
+    end if
+    if(present(f)) then
+        counter=counter+1
+        rbuff(counter)=f
+    end if
+
+    call mpi_bcast(rbuff , counter, mpi_double_precision, boss, mpi_comm_world  ,ierr)
+
+    counter=1
+    a=rbuff(counter)
+    if(present(b)) then
+        counter=counter+1
+        b=rbuff(counter)
+    end if
+    if(present(c)) then
+        counter=counter+1
+        c=rbuff(counter)
+    end if
+    if(present(d)) then
+        counter=counter+1
+        d=rbuff(counter)
+    end if
+    if(present(e)) then
+        counter=counter+1
+        e=rbuff(counter)
+    end if
+    if(present(f)) then
+        counter=counter+1
+        f=rbuff(counter)
+    end if
+  end subroutine qmpi_broadcast_real8s
+  
+  subroutine qmpi_broadcast_logicals(a,b,c,d,e,f,root)
+!
+! send a,b,c,d,e,f out to all processes. if not given
+! process 0 will be used as the sender - root otherwise.
+!
+    implicit none
+    logical a
+    logical, optional :: b,c,d,e,f
+    integer, optional :: root
+    integer counter,boss
+    logical lbuff(6)
+
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+
+    counter=1
+    lbuff(counter)=a
+    if(present(b)) then
+        counter=counter+1
+        lbuff(counter)=b
+    end if
+    if(present(c)) then
+        counter=counter+1
+        lbuff(counter)=c
+    end if
+    if(present(d)) then
+        counter=counter+1
+        lbuff(counter)=d
+    end if
+    if(present(e)) then
+        counter=counter+1
+        lbuff(counter)=e
+    end if
+    if(present(f)) then
+        counter=counter+1
+        lbuff(counter)=f
+    end if
+
+    call mpi_bcast(lbuff , counter, mpi_logical, boss, mpi_comm_world  ,ierr)
+
+    counter=1
+    a=lbuff(counter)
+
+    if(present(b)) then
+        counter=counter+1
+        b=lbuff(counter)
+    end if
+    if(present(c)) then
+        counter=counter+1
+        c=lbuff(counter)
+    end if
+    if(present(d)) then
+        counter=counter+1
+        d=lbuff(counter)
+    end if
+    if(present(e)) then
+        counter=counter+1
+        e=lbuff(counter)
+    end if
+    if(present(f)) then
+        counter=counter+1
+        f=lbuff(counter)
+    end if
+  end subroutine qmpi_broadcast_logicals
+
+  subroutine qmpi_broadcast_integer4s(a,b,c,d,e,f,root)
+!
+! send a,b,c,d,e,f out to all processes. if not given
+! process 0 will be used as the sender - root otherwise.
+!
+    implicit none
+    integer(sp) a
+    integer(sp), optional :: b,c,d,e,f,root
+    integer counter,boss
+    integer ibuff(6)
+
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+
+    counter=1
+!    if(present(a)) then
+!        counter=counter+1
+        ibuff(counter)=a
+!    end if
+    if(present(b)) then
+        counter=counter+1
+        ibuff(counter)=b
+    end if
+    if(present(c)) then
+        counter=counter+1
+        ibuff(counter)=c
+    end if
+    if(present(d)) then
+        counter=counter+1
+        ibuff(counter)=d
+    end if
+    if(present(e)) then
+        counter=counter+1
+        ibuff(counter)=e
+    end if
+    if(present(f)) then
+        counter=counter+1
+        ibuff(counter)=f
+    end if
+
+    call mpi_bcast(ibuff , counter, mpi_integer, boss, mpi_comm_world  ,ierr)
+
+    counter=1
+    a=ibuff(counter)
+
+    if(present(b)) then
+        counter=counter+1
+        b=ibuff(counter)
+    end if
+    if(present(c)) then
+        counter=counter+1
+        c=ibuff(counter)
+    end if
+    if(present(d)) then
+        counter=counter+1
+        d=ibuff(counter)
+    end if
+    if(present(e)) then
+        counter=counter+1
+        e=ibuff(counter)
+    end if
+    if(present(f)) then
+        counter=counter+1
+        f=ibuff(counter)
+    end if
+  end subroutine qmpi_broadcast_integer4s
+
+  subroutine qmpi_broadcast_integer8s(a,b,c,d,e,f,root)
+!
+! send a,b,c,d,e,f out to all processes. if not given
+! process 0 will be used as the sender - root otherwise.
+!
+    implicit none
+    integer(long) a
+    integer(long), optional :: b,c,d,e,f,root
+    integer counter,boss
+    integer ibuff(6)
+
+    boss=0
+    if(present(root)) then
+        boss=root
+    end if
+
+    counter=1
+!    if(present(a)) then
+!        counter=counter+1
+        ibuff(counter)=a
+!    end if
+    if(present(b)) then
+        counter=counter+1
+        ibuff(counter)=b
+    end if
+    if(present(c)) then
+        counter=counter+1
+        ibuff(counter)=c
+    end if
+    if(present(d)) then
+        counter=counter+1
+        ibuff(counter)=d
+    end if
+    if(present(e)) then
+        counter=counter+1
+        ibuff(counter)=e
+    end if
+    if(present(f)) then
+        counter=counter+1
+        ibuff(counter)=f
+    end if
+
+    call mpi_bcast(ibuff , counter, mpi_integer8, boss, mpi_comm_world  ,ierr)
+
+    counter=1
+    a=ibuff(counter)
+
+    if(present(b)) then
+        counter=counter+1
+        b=ibuff(counter)
+    end if
+    if(present(c)) then
+        counter=counter+1
+        c=ibuff(counter)
+    end if
+    if(present(d)) then
+        counter=counter+1
+        d=ibuff(counter)
+    end if
+    if(present(e)) then
+        counter=counter+1
+        e=ibuff(counter)
+    end if
+    if(present(f)) then
+        counter=counter+1
+        f=ibuff(counter)
+    end if
+  end subroutine qmpi_broadcast_integer8s
+
+  subroutine qmpi_real_reduction(type,a,b,c,d,e,f,root)
+!
+! perform a reduction of 'type' on each of the given arguments a - f. 
+! if type is:
+!  'sum': for each argument, return the sum of the argument over all processors
+!  'mul': the product
+!  'min': the minimum value
+!  'max': the maximum value
+! root is an optional argument, if given only return the result on that processor (reduce)
+!  the default is to return the result on all processors (allreduce)
+!    
+    implicit none
+    character(3) type
+    real(sp) a
+    real(sp), optional, intent(inout) :: b,c,d,e,f
+    integer, optional :: root
+    integer counter,boss
+    integer, parameter :: dp=8
+    real(dp) rbuff(6),globrbuff(6)
+
+    if( trim(type).ne.'sum' .and. trim(type).ne.'mul' .and. trim(type).ne.'min' .and. trim(type).ne.'max')then
+        print *,'qmpi.f90 reduce error: reduction of type ',type,'not supported'
+        stop
+    end if
+    
+    boss=0
+    if(present(root)) boss=root
+
+    globrbuff(:)=0.0
+    counter=0
+!    if(present(a)) then
+        counter=counter+1
+        rbuff(counter)=real(a,dp)
+!    end if
+    if(present(b)) then
+        counter=counter+1
+        rbuff(counter)=real(b,dp)
+    end if
+    if(present(c)) then
+        counter=counter+1
+        rbuff(counter)=real(c,dp)
+    end if
+    if(present(d)) then
+        counter=counter+1
+        rbuff(counter)=real(d,dp)
+    end if
+    if(present(e)) then
+        counter=counter+1
+        rbuff(counter)=real(e,dp)
+    end if
+    if(present(f)) then
+        counter=counter+1
+        rbuff(counter)=real(f,dp)
+    end if
+
+    select case(type)
+    case('sum')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_sum,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_sum,mpi_comm_world,ierr)
+        end if
+    case('mul')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_prod,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_prod,mpi_comm_world,ierr)
+        end if
+    case('min')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_min,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_min,mpi_comm_world,ierr)
+        end if
+    case('max')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_max,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_max,mpi_comm_world,ierr)
+        end if
+    end select
+
+    counter=0
+!    if(present(a)) then
+        counter=counter+1
+        a=globrbuff(counter)
+!    end if
+    if(present(b)) then
+        counter=counter+1
+        b=globrbuff(counter)
+    end if
+    if(present(c)) then
+        counter=counter+1
+        c=globrbuff(counter)
+    end if
+    if(present(d)) then
+        counter=counter+1
+        d=globrbuff(counter)
+    end if
+    if(present(e)) then
+        counter=counter+1
+        e=globrbuff(counter)
+    end if
+    if(present(f)) then
+        counter=counter+1
+        f=globrbuff(counter)
+    end if
+  end subroutine qmpi_real_reduction
+
+  subroutine qmpi_real8_reduction(type,a,b,c,d,e,f,root)
+!
+! perform a reduction of 'type' on each of the given arguments a - f. 
+! if type is:
+!  'sum': for each argument, return the sum of the argument over all processors
+!  'mul': the product
+!  'min': the minimum value
+!  'max': the maximum value
+! root is an optional argument, if given only return the result on that processor (reduce)
+!  the default is to return the result on all processors (allreduce)
+!    
+    implicit none
+    integer, parameter :: dp=8
+    character(3) type
+    real(dp) a
+    real(dp), optional, intent(inout) :: b,c,d,e,f
+    integer, optional :: root
+    integer counter,boss
+    real(dp) rbuff(6),globrbuff(6)
+
+    if( trim(type).ne.'sum' .and. trim(type).ne.'mul' .and. trim(type).ne.'min' .and. trim(type).ne.'max')then
+        print *,'qmpi.f90 reduce error: reduction of type ',type,'not supported'
+        stop
+    end if
+
+    boss=0
+    if(present(root))boss=root
+
+    globrbuff(:)=0.0
+    counter=0
+!    if(present(a)) then
+        counter=counter+1
+        rbuff(counter)=a
+!    end if
+    if(present(b)) then
+        counter=counter+1
+        rbuff(counter)=b
+    end if
+    if(present(c)) then
+        counter=counter+1
+        rbuff(counter)=c
+    end if
+    if(present(d)) then
+        counter=counter+1
+        rbuff(counter)=d
+    end if
+    if(present(e)) then
+        counter=counter+1
+        rbuff(counter)=e
+    end if
+    if(present(f)) then
+        counter=counter+1
+        rbuff(counter)=f
+    end if
+    
+    select case(type)
+    case('sum')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_sum,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_sum,mpi_comm_world,ierr)
+        end if
+    case('mul')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_prod,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_prod,mpi_comm_world,ierr)
+        end if
+    case('min')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_min,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_min,mpi_comm_world,ierr)
+        end if
+    case('max')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_max,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter,mpi_double_precision,mpi_max,mpi_comm_world,ierr)
+        end if
+    end select
+
+    counter=0
+!    if(present(a)) then
+        counter=counter+1
+        a=globrbuff(counter)
+!    end if
+    if(present(b)) then
+        counter=counter+1
+        b=globrbuff(counter)
+    end if
+    if(present(c)) then
+        counter=counter+1
+        c=globrbuff(counter)
+    end if
+    if(present(d)) then
+        counter=counter+1
+        d=globrbuff(counter)
+    end if
+    if(present(e)) then
+        counter=counter+1
+        e=globrbuff(counter)
+    end if
+    if(present(f)) then
+        counter=counter+1
+        f=globrbuff(counter)
+    end if
+  end subroutine qmpi_real8_reduction
+
+  subroutine qmpi_integer_reduction(type,a,b,c,d,e,f,root)
+!
+! perform a reduction of 'type' on each of the given arguments a - f. 
+! if type is:
+!  'sum': for each argument, return the sum of the argument over all processors
+!  'mul': the product
+!  'min': the minimum value
+!  'max': the maximum value
+! root is an optional argument, if given only return the result on that processor (reduce)
+!  the default is to return the result on all processors (allreduce)
+!    
+    implicit none
+    character(3) type
+    integer(sp) a
+    integer(sp), optional, intent(inout) :: b,c,d,e,f
+    integer, optional :: root
+    integer counter,boss
+    integer rbuff(6),globrbuff(6)
+
+    if( trim(type).ne.'sum' .and. trim(type).ne.'mul' .and. trim(type).ne.'min' .and. trim(type).ne.'max')then
+        print *,'qmpi.f90 reduce error: reduction of type ',type,'not supported'
+        stop
+    end if
+
+    boss=0
+    if(present(root))boss=root
+
+    globrbuff(:)=0
+    counter=0
+    !if(present(a)) then
+        counter=counter+1
+        rbuff(counter)=a
+    !end if
+    if(present(b)) then
+        counter=counter+1
+        rbuff(counter)=b
+    end if
+    if(present(c)) then
+        counter=counter+1
+        rbuff(counter)=c
+    end if
+    if(present(d)) then
+        counter=counter+1
+        rbuff(counter)=d
+    end if
+    if(present(e)) then
+        counter=counter+1
+        rbuff(counter)=e
+    end if
+    if(present(f)) then
+        counter=counter+1
+        rbuff(counter)=f
+    end if
+
+    select case(type)
+    case('sum')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_sum,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_sum,mpi_comm_world,ierr)
+        end if
+    case('mul')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_prod,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_prod,mpi_comm_world,ierr)
+        end if
+    case('min')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_min,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_min,mpi_comm_world,ierr)
+        end if
+    case('max')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_max,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER, mpi_max,mpi_comm_world,ierr)
+        end if
+    end select
+
+    counter=0
+!    if(present(a)) then
+        counter=counter+1
+        a=globrbuff(counter)
+!    end if
+    if(present(b)) then
+        counter=counter+1
+        b=globrbuff(counter)
+    end if
+    if(present(c)) then
+        counter=counter+1
+        c=globrbuff(counter)
+    end if
+    if(present(d)) then
+        counter=counter+1
+        d=globrbuff(counter)
+    end if
+    if(present(e)) then
+        counter=counter+1
+        e=globrbuff(counter)
+    end if
+    if(present(f)) then
+        counter=counter+1
+        f=globrbuff(counter)
+    end if
+  end subroutine qmpi_integer_reduction
+
+  subroutine qmpi_integer8_reduction(type,a,b,c,d,e,f,root)
+!
+! perform a reduction of 'type' on each of the given arguments a - f. 
+! if type is:
+!  'sum': for each argument, return the sum of the argument over all processors
+!  'mul': the product
+!  'min': the minimum value
+!  'max': the maximum value
+! root is an optional argument, if given only return the result on that processor (reduce)
+!  the default is to return the result on all processors (allreduce)
+!    
+    implicit none
+    character(3) type
+    integer(long) a
+    integer(long), optional, intent(inout) :: b,c,d,e,f
+    integer, optional :: root
+    integer counter,boss
+    integer(long) rbuff(6),globrbuff(6)
+
+    if(len(type).ne.3)then
+        print *,'qmpi.f90 reduce error: type must be one of "mul","sum","min" or "max"'
+        stop
+    end if
+    if( trim(type).ne.'sum' .and. trim(type).ne.'mul' .and. trim(type).ne.'min' .and. trim(type).ne.'max')then
+        print *,'qmpi.f90 reduce error: reduction of type ',type,'not supported'
+        stop
+    end if
+
+    boss=0
+    if(present(root))boss=root
+
+    globrbuff(:)=0_dp
+    counter=0
+!    if(present(a)) then
+        counter=counter+1
+        rbuff(counter)=a
+!    end if
+    if(present(b)) then
+        counter=counter+1
+        rbuff(counter)=b
+    end if
+    if(present(c)) then
+        counter=counter+1
+        rbuff(counter)=c
+    end if
+    if(present(d)) then
+        counter=counter+1
+        rbuff(counter)=d
+    end if
+    if(present(e)) then
+        counter=counter+1
+        rbuff(counter)=e
+    end if
+    if(present(f)) then
+        counter=counter+1
+        rbuff(counter)=f
+    end if
+
+    select case(type)
+    case('sum')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_sum,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_sum,mpi_comm_world,ierr)
+        end if
+    case('mul')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_prod,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_prod,mpi_comm_world,ierr)
+        end if
+    case('min')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_min,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_min,mpi_comm_world,ierr)
+        end if
+    case('max')
+        if(present(root))then
+            call mpi_reduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_max,boss,mpi_comm_world,ierr)
+        else
+            call mpi_allreduce(rbuff,globrbuff,counter, MPI_INTEGER8, mpi_max,mpi_comm_world,ierr)
+        end if
+    end select
+
+    counter=1
+    a=globrbuff(counter)
+    
+    if(present(b)) then
+        counter=counter+1
+        b=globrbuff(counter)
+    end if
+    if(present(c)) then
+        counter=counter+1
+        c=globrbuff(counter)
+    end if
+    if(present(d)) then
+        counter=counter+1
+        d=globrbuff(counter)
+    end if
+    if(present(e)) then
+        counter=counter+1
+        e=globrbuff(counter)
+    end if
+    if(present(f)) then
+        counter=counter+1
+        f=globrbuff(counter)
+    end if
+  end subroutine qmpi_integer8_reduction
+
+
+! later?
+! packing to reduce number of sends:
+  
+! call pack(u)
+! call pack(eta(1,:))
+! call pack(v)
+! call send_pack(1)
+! ...
+! call receive_pack(0)
+! call unpack(u)
+! call unpack(eta(1,:)
+!
+  
+end module qmpi
+
+#else
+
+#warning "COMPILING WITHOUT QMPI CODE"
+
+module qmpi_fake
+  implicit none
+
+  logical, parameter :: master = .true.
+  integer, parameter :: qmpi_num_proc = 1
+  integer, parameter :: qmpi_proc_num = 0
+
+contains
+
+  subroutine stop_mpi()
+    stop 
+  end subroutine stop_mpi
+
+end module qmpi_fake
+
+#endif

README.md

@@ -1,3 +1,118 @@
-# EnKF
+November 2016
+Updated  November 2017
+
+François Massonnet
+francois.massonnet@bsc.es/uclouvain.be
+
+Everything available to set up the ensemble Kalman filter for NEMO and EC-Earth
+
+|-----------------------------------------------------------------------|
+|ALL COMPILATIONS AND CREATION OF BINARY FILES SHOULD BE DONE ON THE HPC|
+|-----------------------------------------------------------------------|
+
+1/ Go to the HPC
+
+2/ Clone the git repository (some HPCs don't allow communication with the web, in this case clone locally and rsync the git project to HPC)
+
+>> git clone https://earth.bsc.es/gitlab/fmassonnet/EnKF-assimilation.git
+
+3/ Check-out the appropriate branch
+>> git checkout develop-${HPC}
+where ${HPC} is for instance mn4
+
+The file enkf_modules_to_load.txt is a set of modules to be load at compilation and execution to make sure that all libraries are found
+
+
+A/ Compilation of the EnKF code
+-------------------------------
+The folder EnKF-MPI-TOPAZ is a modified copy of the source code found at NERSC (http://enkf.nersc.no/Code/NERSC_implementation/V2/)
+
+It has been modified as to work with NEMO and LIM, by F. Massonnet and C. König Beatty.
+
+___THE CODE SHOULD NOT BE MODIFIED___
+
+
+>> cd EnKF-MPI-TOPAZ
+>> make clean
+>> source ../enkf_modules_to_load.txt
+>> make 
+
+An executable EnKF should be produced. Try to run it to see if you get the following information message:
+
+   bsc32526@login2:/gpfs/projects/bsc32/bsc32526/enkf/EnKF-assimilation/EnKF-MPI-TOPAZ> ./EnKF
+   Inne i start_mpi: qmpi_proc_num =           0  master = T
+   MPI started with 1 processors
+   Usage: EnKF <parameter file>
+          EnKF -h
+   Options:
+     -h -- describe parameter fie format
+
+B/ Compilation of the program to convert NetCDF files to binaries
+-----------------------------------------------------------------
+>> cd ../conversion_uf/
+>> make clean
+>> source ../enkf_modules_to_load.txt
+>> make
+
+Two executables named prep_obs_ORCA1 and prep_obs_ORCA25 should be created. Try them:
+>> ./prep_obs_ORCA1
+           0
+ 
+  (prep_obs) takes a real obs, extracts the desired variable and outputs
+  it in a format that the EnKF can read & treat ('observations.uf').
+ 
+  A file named mask.nc containing the variables tmaskutil, nav_lon and nav_lat
+  is expected to be in the current directory (ORCA-file)
+ 
+  Three command line arguments are expected:
+  1. Path to the nc file of which the data is to be extracted.
+  2. Variable name that can be found in there, 'h_i_htc1' or
+     'at_i'. or dxdy_ice
+  3. A tag with the date, e.g. 19790520
+ 
+  Hope to see you again soon.
+ 
+(prep_obs): Stopped.
+
+C/ Compilation of the program to post-process the restarts after assimilation ("sanity_check")
+----------------------------------------------------------------------------------------------
+The folder sanity_check is a set of routines that make sure that the restarts provided by the EnKF can be read by NEMO. These are home-made (François Massonnet, see also description in http://www.sciencedirect.com/science/article/pii/S1463500315000050
+
+
+>> cd ../sanity_check/
+>> make clean
+>> source ../enkf_modules_to_load.txt
+>> make
+
+An executable named sanity_checked is created, try it:
+>> ./sanity_check
+ 
+  sanity_check_LIM3 needs arguments: 
+  -analysis_file_ice 
+  -forecast_file_ice 
+  -analysis_file_oce 
+  -forecast_file_oce 
+  Checks NEMO-LIM3 ice and ocean analyses restarst (netcdf) file for sanity and 
+ fixesthem if necessary.
+ 
+  Sanity means for now:
+  Strongly follow limupdate.F90
+  Files mask.nc and mesh_hgr.nc need to be in the current directory
+ 
+  Hope to see you again soon.
+ 
+  Chris König Beatty 
+  Francois Massonnet -- francois.massonnet@uclouvain.be
+  Last update: 2013
+  Last update: 2016 (to work with NEMO3.6)
+(sanity_check): Stopped.
+
+
+
+D/ Convert NetCDF observations (already interpolated on the ORCA grids) to UF format:
+-------------------------------------------------------------------------------------
+>> cd ../conversion_uf/
+
+open convert.bash, check it, and run it (always on HPC)
+
 
-Tools from NERSC to run the Ensemble Kalman Filter, adapted to NEMO.

conversion_uf/MODEL.CPP

@@ -0,0 +1,8 @@
+#undef TEST_2D
+#undef LINUX
+#undef DEBUG
+#undef TEST_1D
+#define ICE
+#define EXPCOV
+#undef CHECK_SOLUTION
+#undef X4SVD