compilation EnKF

EnKF-MPI-TOPAZ/TMP/EnKF.f90

@@ -0,0 +1,387 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+! 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
+
+  use qmpi
+
+
+
+  use m_parameters
+  use distribute
+  use mod_measurement
+  use m_get_mod_grid
+  use m_get_mod_nrens
+  use m_get_mod_xyz ! Added by Francois Massonnet [FM] May 2013 and Apr 2016 !
+  use m_obs
+  use m_local_analysis
+  use m_prep_4_EnKF
+  use m_set_random_seed2
+  !use m_get_mod_fld  ! Taken out and simplified by m_io_mod_fld
+  !use m_put_mod_fld
+  use m_io_mod_fld    ![CKB,FM] was: m_get_mod_fld and m_put_mod_fld
+  use mod_analysisfields
+  use m_parse_blkdat
+  use m_random
+  use m_point2nc
+  implicit none
+
+  character(*), parameter :: ENKF_VERSION = "2.11"
+
+
+  integer, intrinsic :: iargc
+
+
+
+
+  ! NFIELD is the number of fields (x N) passed for the update during a call to
+  ! update_fields(). In TOPAZ4 NFIELD = 2 if there is 1 GB of RAM per node, and
+  ! NFIELD = 4 if there are 2 GB of RAM. Higher value of NFIELD reduces the
+  ! number of times X5tmp.uf is read from disk, which is the main bottleneck
+  ! for the analysis time right now.
+  !
+  integer, parameter :: NFIELD = 8
+
+  character(512) :: options
+
+  integer :: nrens
+  integer, allocatable, dimension(:) :: enslist ! [FM] List of existing
+                                                ! ensemble members
+  real, allocatable, dimension(:,:) :: modlon, modlat, depths, readfld
+  real, allocatable, dimension(:,:) :: S ! ensemble observations HE
+  real, allocatable, dimension(:)   :: d ! d - Hx
+
+  integer k, m
+
+  ! "New" variables used in the parallelization 
+  integer, dimension(:,:), allocatable :: nlobs_array
+  real(4), allocatable :: fld(:,:)
+  real(8) rtc, time0, time1, time2
+
+  ! Additional fields
+  character(len=3) :: cmem
+  character(len=80) :: memfile
+  integer :: fieldcounter
+
+  character(100) :: text_string
+
+  real :: rdummy
+  integer :: idm, jdm, kdm
+
+  real :: mindx
+  real :: meandx
+  integer :: m1, m2, nfields
+  real :: infls(NFIELD)
+
+
+  call start_mpi()
+
+
+  ! 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))
+
+
+   call barrier()
+
+
+   ! get fieldnames and fieldlevels
+   !
+   call get_analysisfields()
+
+   call distribute_iterations(numfields)
+
+   call barrier() !KAL - just for "niceness" of output
+
+   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
+
+   call barrier()
+
+   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
+
+
+ ! not tested! - PS
+ !
+ real function rtc()
+   integer :: c
+
+   call system_clock(count=c)
+   rtc = dfloat(c)
+ end function rtc

EnKF-MPI-TOPAZ/TMP/distribute.f90

@@ -0,0 +1,157 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+module distribute
+
+
+  use qmpi
+
+
+
+
+  !
+  ! 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/TMP/m_Generate_element_Si.f90

@@ -0,0 +1,474 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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/TMP/m_bilincoeff.f90

@@ -0,0 +1,161 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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/TMP/m_confmap.f90

@@ -0,0 +1,175 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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/TMP/m_get_mod_fld.f90

@@ -0,0 +1,199 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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)
+
+   use qmpi
+
+
+
+   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     MODEL #########################
+!###################################################################
+
+
+   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)
+
+
+
+
+
+  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
+
+   use qmpi, only : qmpi_proc_num, master
+
+
+
+   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/TMP/m_get_mod_grid.f90

@@ -0,0 +1,223 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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
+
+  use qmpi
+
+
+
+
+  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/TMP/m_get_mod_nrens.f90

@@ -0,0 +1,130 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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.
+!
+
+   use qmpi, only : stop_mpi, master
+
+
+
+
+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
+
+   integer                nrice         ! ice file counter
+
+
+   ! 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
+
+
+   ! 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
+
+
+end subroutine get_mod_nrens
+end module m_get_mod_nrens

EnKF-MPI-TOPAZ/TMP/m_get_mod_xyz.f90

@@ -0,0 +1,153 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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
+
+  use qmpi
+
+
+
+
+  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/TMP/m_insitu.f90

@@ -0,0 +1,842 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+! 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
+
+   use qmpi
+
+
+
+  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/TMP/m_io_mod_fld.f90

@@ -0,0 +1,219 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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
+
+  use qmpi
+
+
+
+
+  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/TMP/m_local_analysis.f90

@@ -0,0 +1,1045 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+! 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)
+
+    use qmpi
+
+
+
+    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)
+
+    use qmpi
+
+
+
+    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
+
+    integer, allocatable, dimension(:, :) :: mpibuffer_int
+    real(4), allocatable, dimension(:, :) :: mpibuffer_float1, mpibuffer_float2
+
+
+    integer :: lapack_info
+
+
+    integer :: p
+
+    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
+
+    call barrier()
+
+    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 (.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)
+
+
+    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/TMP/m_obs.f90

@@ -0,0 +1,432 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+! 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
+
+    use qmpi
+
+
+
+  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/TMP/m_oldtonew.f90

@@ -0,0 +1,102 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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/TMP/m_parameters.f90

@@ -0,0 +1,322 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+! 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
+
+  use qmpi
+
+
+
+  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/TMP/m_parse_blkdat.f90

@@ -0,0 +1,195 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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/TMP/m_pivotp.f90

@@ -0,0 +1,105 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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/TMP/m_point2nc.f90

@@ -0,0 +1,393 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+! 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()
+
+    use qmpi
+
+
+
+
+    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
+
+    use qmpi
+
+
+
+    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 (.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
+
+
+    ! 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/TMP/m_prep_4_EnKF.f90

@@ -0,0 +1,761 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+! 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)
+
+    use qmpi, only : master, stop_mpi
+
+
+
+    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)
+
+    use qmpi
+
+
+
+    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/TMP/m_put_mod_fld.f90

@@ -0,0 +1,119 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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/TMP/m_random.f90

@@ -0,0 +1,105 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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/TMP/m_read_icemod.f90

@@ -0,0 +1,117 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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
+
+  use qmpi
+
+
+
+
+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/TMP/m_set_random_seed2.f90

@@ -0,0 +1,150 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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. 
+
+   use qmpi
+
+
+
+   implicit none 
+
+   integer , dimension(8)::val
+   integer cnt
+   integer sze
+   integer, allocatable, dimension(:):: pt
+
+   integer :: q
+
+
+   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 (master) then
+      do q=2,qmpi_num_proc
+         call send(pt,q-1)
+      end do
+   else
+      call receive(pt,0)
+   end if
+
+   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
+
+   use qmpi
+
+
+
+      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 (master) then
+      do q=2,qmpi_num_proc
+         call send(rpt,q-1)
+      end do
+   else
+      call receive(rpt,0)
+   end if
+
+      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/TMP/m_spherdist.f90

@@ -0,0 +1,84 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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/TMP/m_uobs.f90

@@ -0,0 +1,164 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+! 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
+
+    use qmpi
+
+
+
+  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/TMP/mod_analysisfields.f90

@@ -0,0 +1,210 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+!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()
+
+
+   use qmpi
+
+
+
+
+   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()
+
+
+   use qmpi
+
+
+
+
+   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/TMP/mod_measurement.f90

@@ -0,0 +1,86 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+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/TMP/mod_raw_io.f

@@ -0,0 +1,448 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+      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/TMP/nfw.f90

@@ -0,0 +1,752 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 10 "<stdin>"
+!
+! 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
+
+
+
+
+
+
+
+  ! 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/TMP/qmpi.f90

@@ -0,0 +1,2105 @@
+# 0 "<stdin>"
+# 0 "<built-in>"
+# 0 "<command-line>"
+
+
+# 1 "/usr/include/stdc-predef.h" 1 3 4
+
+# 17 "/usr/include/stdc-predef.h" 3 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# 2 "<command-line>" 2
+# 1 "<stdin>"
+# 11 "<stdin>"
+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
+! ...
+!  
+
+  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
+