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/Config/make.zenobe

@@ -0,0 +1,38 @@
+# Library and include
+
+INC_NETCDFF = -I${EBROOTNETCDFMINFORTRAN}/include
+INC_NETCDF = -I${EBROOTNETCDF}/include
+LIB_NETCDF = -L${EBROOTNETCDF}/lib64 -lnetcdf
+LIB_NETCDFF = -L${EBROOTNETCDFMINFORTRAN}/lib -lnetcdff
+INC_LAPACK = -I${EBROOTSCALAPACK}/include
+LIB_LAPACK = -L${EBROOTSCALAPACK}/lib -lscalapack
+LIB_BLAS = -L${EBROOTOPENBLAS}/lib -lopenblas
+INC_BLAS = -I${EBROOTOPENBLAS}/include
+INC_FFT = -I${EBROOTFFTW}/include
+LIB_FFT = -L${EBROOTFFTW}/lib -lfftw3 -lfftw3_mpi
+
+INCS = $(INC_NETCDF) $(INC_FFT) $(INC_NETCDFF) $(INC_LAPACK) $(INC_BLAS)
+LIBS = $(LIB_NETCDF) $(LIB_NETCDFF) $(LIB_FFT) $(LIB_LAPACK) $(LIB_BLAS)
+
+CF90 = mpif90
+CPPFLAGS = -D_G95_ -DQMPI
+CF77 = $(CF90)
+LD = $(CF90)
+CPP = cpp -traditional-cpp
+CC = mpicc
+
+CPPARCH =
+CPPFLAGS +=
+
+SIZEO = -fdefault-real-8
+OPTO = -O3
+DEBUG_FLAGS = #-g -traceback -W1 -warn unused -warn uncalled -debug extended -debug-parameters -ftrapuv -fpe0
+
+FFLAGS = $(SIZEO) $(OPTO) $(DEBUG_FLAGS) $(INCS)
+CFLAGS = -Df2cFortran $(OPTO) $(INCS)
+LINKFLAGS = $(SIZEO) $(OPTO) $(DEBUG_FLAGS) $(LIBS)
+
+# language-specific flags
+#
+F77FLG =
+F90FLG =

EnKF-MPI-TOPAZ/EnKF.F90

@@ -0,0 +1,334 @@
+! 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"
+
+#if defined(_G95_)
+  integer, intrinsic :: iargc
+#else
+  integer, external :: iargc
+#endif
+
+  ! 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,165 @@
+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,378 @@
+! 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 :: RFB_MIN  = 0.0d0          ! FM 2020
+  real, parameter, private :: RFB_MAX  = 10.0d0
+  real, parameter, private :: VT_I_MIN  = 0.0d0          ! FM 2020
+  real, parameter, private :: VT_I_MAX  = 10.0d0
+  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
+    CHARACTER(LEN=*), PARAMETER  :: &
+ FMT2 = "(f8.4,X,f8.4,X,a8,X,2(f10.5,X),f4.2,X,2(I3,X),I1,X,4(f5.2,X),L,X,2(I3,X),f5.2,X,I8,X,I1)"
+    real :: myX
+    real :: myY
+
+
+
+!==========  TEST
+!    inquire(iolength = rsize) record
+!    !open(10, file = 'test.txt', form = 'unformatted',&
+!    !     access = 'direct', recl = rsize, status = 'old')
+!    allocate(obs(2))
+!    open(10, file = 'observations.txt')!, form = 'unformatted',&
+!          !access = 'direct', recl = rsize, status = 'old')
+!    !read(10, *) obs(1)
+!
+!    do o = 1, 2
+!      read(10, *) obs(o)
+!      PRINT *, obs(o)
+!    end do
+!    close(10)
+!    stop
+!==========
+
+    if (nobs >= 0) then
+       return
+    end if
+
+    ! Testing existence of file
+    inquire(file = 'observations.txt', exist = exists)
+    !inquire(file = 'observations.uf', exist = exists)
+    if (.not. exists) then
+       if (master) then
+          print *, 'ERROR: obs_getnobs(): file "observations.txt" does not exist'
+       end if
+       stop
+    end if
+    inquire(iolength = rsize) record
+    open(10, file = 'observations.txt')!, form = 'unformatted',&
+    ! EXPERIMENTAL
+    !open(10, file = 'observations.uf', form = 'unformatted',&
+    !         access = 'direct', recl = rsize, status = 'old')!, form = 'unformatted',&
+         !access = 'direct', recl = rsize, status = 'old')
+    ! END EXPERIMENTAL
+    ! 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, *, 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.txt')!, form = 'unformatted',&
+
+    ! BEGIN EXPERIMENTAL
+    !open(10, file = 'observations.uf', form = 'unformatted',&
+    !         access = 'direct', recl = rsize, status = 'old')
+    ! -- END EXPERIMENTAL
+    do o = 1, nobs
+       read(10, *) obs(o)
+       
+       call ucase(obs(o) % id)
+       !PRINT *, obs(o)
+    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)) == 'RFB') then      ! FM added 2020
+          dmin = RFB_MIN
+          dmax = RFB_MAX
+       elseif (trim(unique_obs(uo)) == 'VT_I') then      ! FM added 2021
+          dmin = VT_I_MIN
+          dmax = VT_I_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,707 @@
+! 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)
+    real :: vi1(nx,ny), vi2(nx,ny), vi3(nx,ny), vi4(nx,ny), vi5(nx,ny)
+    real :: vs1(nx,ny), vs2(nx,ny), vs3(nx,ny), vs4(nx,ny), vs5(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
+             ! Multipply by 100 to match obs conventions
+             readfld=(ai1+ai2+ai3+ai4+ai5) * 100.0
+
+             call Generate_element_Si(S(:, iens), unique_obs(iuobs),&
+                  readfld, depths, nx, ny, nz, 0)
+          end do
+
+       ! freeboard
+       elseif(trim(unique_obs(iuobs)) == 'VT_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))
+
+             call io_mod_fld(vi1,iens,enslist, &
+                 'v_i_htc1', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vi2,iens,enslist, &
+                 'v_i_htc2', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vi3,iens,enslist, &
+                 'v_i_htc3', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vi4,iens,enslist, &
+                 'v_i_htc4', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vi5,iens,enslist, &
+                 'v_i_htc5', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+
+
+             if (tlevel == -1) then
+                 if (master) then
+                   print *, 'ERROR: io_mod_fld_nex(): failed for "SIFB"'
+                 end if
+                 stop
+             end if
+
+
+
+             readfld=(vi1+vi2+vi3+vi4+vi5) 
+             call Generate_element_Si(S(:, iens), unique_obs(iuobs),&
+                  readfld, depths, nx, ny, nz, 0)
+           end do
+
+
+       ! freeboard
+       elseif(trim(unique_obs(iuobs)) == 'RFB') 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))
+
+             call io_mod_fld(vi1,iens,enslist, &
+                 'v_i_htc1', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vi2,iens,enslist, &
+                 'v_i_htc2', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vi3,iens,enslist, &
+                 'v_i_htc3', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vi4,iens,enslist, &
+                 'v_i_htc4', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vi5,iens,enslist, &
+                 'v_i_htc5', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+
+             call io_mod_fld(vs1,iens,enslist, &
+                 'v_s_htc1', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vs2,iens,enslist, &
+                 'v_s_htc2', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vs3,iens,enslist, &
+                 'v_s_htc3', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vs4,iens,enslist, &
+                 'v_s_htc4', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+             call io_mod_fld(vs5,iens,enslist, &
+                 'v_s_htc5', 1, 0, 1, nx,ny, 'get',FLOAT(obs(1)%date))
+
+             if (tlevel == -1) then
+                 if (master) then
+                   print *, 'ERROR: io_mod_fld_nex(): failed for "SIFB"'
+                 end if
+                 stop
+             end if
+
+             readfld=(((vi1+vi2+vi3+vi4+vi5) * (1024.0 - 899.5) - 330 * (vs1+vs2+vs3+vs4+vs5)) / &
+                    1024.0-0.25*(vs1 +vs2+vs3+vs4+vs5)) 
+             !readfld=(((vi1+vi2+vi3+vi4+vi5) * (1024.0 - 899.5) - 330 * (vs1+vs2+vs3+vs4+vs5)) / 1024.0 - 0.25 * (vs1+vs2+vs3+vs4+vs5)) / (ai1+ai2+ai3+ai4+ai5)
+             
+             ! Conversion of models' sea ice thickness and snow thickness to
+             ! model's freeboard using fixed densities for snow (330 kg/m3), ice
+             ! (899.5 kg/m3 = average of MYI and FYI from Guerreiro et al. 2017
+             ! and seawater (1024 kg/m3). The model freeboard is then lowered by
+             ! 25% of the snow depth to account for the fact that the radar
+             ! measurement underestimates the actual freeboard due to the lower
+             ! propagation speed of the wave into the snow than in the air.
+             ! Everything is converted from grid cell mean to in situ by
+             ! dividing by concentration (if it is not zero). See exchanges
+             ! e-mail with Sara Fleury 7 December 2020.
+             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,&
+                  'tn', 1, tlevel, nx, ny)
+             PRINT *, "FRANCOIS"
+             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,110 @@
+! 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 = 1900
+
+  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
+       !PRINT *, o
+       !PRINT *, '...', nuobs
+       obsmatch = .false.
+       do uo = 1, nuobs
+          !PRINT *, '-->', uo
+          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 *, trim(tags(o))
+                print *, trim(unique_obs(uo))
+                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.zenobe

EnKF-MPI-TOPAZ/makefile

@@ -0,0 +1,81 @@
+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 "FRANCOIS"
+	@exit
+	@echo "->EnKF"
+	@cd ./TMP ; $(LD) $(LINKFLAGS) -o ../EnKF $(ENKF_OBJ)
+
+$(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,113 @@
-# EnKF
+November 2016
+Updated  November 2017
+Updated  March 2019 at UCL
+
+François Massonnet
+francois.massonnet@uclouvain.be/bsc.es
+
+Everything available to set up the Ensemble Kalman filter (EnKF) 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://gogs.elic.ucl.ac.be/fmasson/EnKF.git
+```
+
+3. **Compile 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 itself should not be modified, unless there are good reasons to do so.
+
+```
+cd EnKF-MPI-TOPAZ
+make clean
+configure_ecearth
+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.