!### macro's #####################################################
!
#define TRACEBACK write (logfu,'("in ",a," (",a,", line",i5,")")') rname, __FILE__, __LINE__
!
#define IF_NOT_OK_RETURN(action) if (status/=0) then; TRACEBACK; action; call Exit(status); end if
!
#include "cso.inc"
!
!#################################################################

program Tutorial_Oper_Adj_Test

#ifdef _MPI
  use MPI_F08, only : MPI_Comm
  use MPI_F08, only : MPI_COMM_WORLD
  use MPI_F08, only : MPI_SUCCESS, MPI_Error_String
  use MPI_F08, only : MPI_Init, MPI_Finalize
  use MPI_F08, only : MPI_Comm_Size, MPI_Comm_Rank
#endif

  use CSO, only : csoc
  use CSO, only : T_CSO
  use CSO, only : T_CSO_RcFile
  use CSO, only : T_CSO_DateTime, T_CSO_TimeDelta, CSO_DateTime, CSO_TimeDelta, Pretty, &
                    operator(+), operator(-), operator(*), operator(>=)
  use CSO, only : T_CSO_Listing
  use CSO, only : T_CSO_Sat_Data
  use CSO, only : T_CSO_Sat_State
  use CSO, only : T_GridMapping
  
  implicit none


  ! --- const ----------------------------------------------------------

  character(len=*), parameter   ::  rname = 'Tutorial_Oper_Adj-Test'
  
  ! gravity constant:
  real, parameter     ::  grav   = 9.80665 ! m/s2
  ! mole mass of air:
  real, parameter     ::  xm_air = 28.964e-3     ! kg/mol : ~80% N2, ~20% O2, ...
  
  ! number of ensemble members, 2 needed for adjoint test:
  integer, parameter  ::  nmem = 2

  ! --- local ----------------------------------------------------------
  
#ifdef _MPI
  type(MPI_Comm)                    ::  comm
  integer                           ::  errorcode
  integer                           ::  errorlen
  character(len=1024)               ::  errormsg
#endif
  integer                           ::  npes, id

  ! return status:
  integer                           ::  status
  
  ! main object for CSO data:  
  type(T_CSO)                       ::  csod
  
  ! logfile unit and filename:
  integer                           ::  logfu
  character(len=1024)               ::  logfile

  ! settings:
  character(len=1024)               ::  rcfile
  type(T_CSO_RcFile)                ::  rcf
  character(len=32)                 ::  rcbase

  ! time loop variables:
  type(T_CSO_DateTime)              ::  t1, t2
  type(T_CSO_DateTime)              ::  t
  type(T_CSO_TimeDelta)             ::  dt
  
  ! local domain definition:
  real                              ::  west, east, south, north
  real                              ::  dlon, dlat
  integer                           ::  nlon, nlat
  ! global domain:
  integer                           ::  gnlon, gnlat
  ! model layers:
  integer                           ::  nz
  
  ! decomposition:
  integer                           ::  ndomx, ndomy
  integer                           ::  idomx, idomy
  real                              ::  dom_west, dom_east, dom_south, dom_north
  integer                           ::  dom_ilon0, dom_ilat0

  ! "model" arrays:
  integer                           ::  ilon, ilat, iz
  real, allocatable                 ::  conc(:,:,:,:)  ! (nlon,nlat,nz,nmem)
  character(len=32)                 ::  conc_units
  real, allocatable                 ::  hp(:,:,:)    ! (nlon,nlat,0:nz)
  character(len=32)                 ::  hp_units
  real, allocatable                 ::  tcc(:,:)   ! (nlon,nlat)
  real, allocatable                 ::  cc(:,:,:)  ! (nlon,nlat,nz)
  character(len=32)                 ::  cc_units

  ! gradient array:
  real, allocatable                 ::  grad(:,:,:)  ! (nlon,nlat,nz)
  character(len=32)                 ::  grad_units

  ! orbit listing:
  character(len=1024)               ::  listing_filename
  type(T_CSO_Listing)               ::  listing
  ! orbit files:
  character(len=1024)               ::  orbit_filename
  ! orbit data and state:
  type(T_CSO_Sat_Data)              ::  sdata
  type(T_CSO_Sat_State)             ::  sstate(nmem)
  ! output filename:
  character(len=1024)               ::  output_filename
  
  ! global pixel arrays:
  integer                           ::  nglb
  real, pointer                     ::  glb_lon(:)       ! (nglb)
  real, pointer                     ::  glb_lat(:)       ! (nglb)
  real, pointer                     ::  glb_clons(:,:)   ! (nglb,4)
  real, pointer                     ::  glb_clats(:,:)   ! (nglb,4)
  logical, pointer                  ::  glb_select(:)    ! (nglb)
  integer                           ::  iglb
  
  ! horizontal mapping:
  integer                           ::  mapping_levels
  type(T_GridMapping)               ::  GridMapping
  ! mapping arrays:
  real, pointer                     ::  areas(:)
  integer, pointer                  ::  ii(:), jj(:)
  real, pointer                     ::  ww(:)
  integer, pointer                  ::  iw0(:), nw(:)
  ! mapping index:
  integer                           ::  iw
  
  ! user defined dimensions:
  integer                           ::  nudim
  integer                           ::  iudim
  character(len=32)                 ::  udimname

  ! user defined variables:
  integer                           ::  nuvar
  integer                           ::  iuvar
  character(len=64), allocatable    ::  uvarnames(:)  ! (nuvar)
  character(len=64), allocatable    ::  uvarunits(:)  ! (nuvar)

  ! pixel counter and index:
  integer                           ::  npix
  integer                           ::  ipix 
  ! pixel footprints:
  real, pointer                     ::  lons(:), lats(:)         ! (npix)
  real, pointer                     ::  clons(:,:), clats(:,:)   ! (ncorner,npix)
  ! pixel arrays:
  real, pointer                     ::  data0(:)          ! (npix)
  real, pointer                     ::  data1(:,:)        ! (:,npix)

  ! collected pixel arrays:
  integer                           ::  nout
  integer                           ::  nlayer
  integer                           ::  nretr
  real, allocatable                 ::  gdata1_z1(:,:)        ! (nz,nout)
  real, allocatable                 ::  gdata1_z2(:,:)        ! (nz,nout)
  real, allocatable                 ::  gdata1_xs1(:,:)       ! (nlayer,nout)
  real, allocatable                 ::  gdata1_xs2(:,:)       ! (nlayer,nout)
  real, allocatable                 ::  gdata1_ys1(:,:)       ! (nretr,nout)
  real, allocatable                 ::  gdata1_ys2(:,:)       ! (nretr,nout)
  real, allocatable                 ::  gdata1_eps(:,:)       ! (nretr,nout)
  real, allocatable                 ::  gdata1_f(:,:)         ! (nlayer,nout)
  real, allocatable                 ::  gdata1_g(:,:)         ! (nz,nout)
  ! adjoint tests:
  real                              ::  gTdx, fTdz
  real                              ::  aver, adiff, rdiff
  integer                           ::  itest
  
  ! ensemble:
  integer                           ::  imem

  ! --- begin ----------------------------------------------------------
  
  ! logfile unit, initially write to stdout:
  logfu = 6

#ifdef _MPI

  ! length of error messages:
  errorlen = len(errormsg)

  ! init MPI interface:
  call MPI_Init( ierror=status )
  if ( status /= MPI_SUCCESS ) then
    errorcode=status; call MPI_Error_String( errorcode, errormsg, errorlen, status ); write (logfu,'(a)') trim(errormsg)
    write (logfu,'("could not initialize MPI environment; exit code : ",i6)') status
    TRACEBACK; status=1; call Exit(status)
  end if
  ! use global communicator:
  comm = MPI_COMM_WORLD
  ! size and rank:
  call MPI_Comm_Size( comm, npes, ierror=status )
  if ( status /= MPI_SUCCESS ) then
    errorcode=status; call MPI_Error_String( errorcode, errormsg, errorlen, status ); write (logfu,'(a)') trim(errormsg)
    TRACEBACK; status=1; call Exit(status)
  end if
  call MPI_Comm_Rank( comm, id, ierror=status )
  if ( status /= MPI_SUCCESS ) then
    errorcode=status; call MPI_Error_String( errorcode, errormsg, errorlen, status ); write (logfu,'(a)') trim(errormsg)
    TRACEBACK; status=1; call Exit(status)
  end if

  ! init CSO module including MPI communication:
  call csod%Init( status, comm=comm )
  IF_NOT_OK_RETURN(status=1)
  
  ! OPTIONALLY: write messages to seperate files:
  write (logfile,'("tutorial.log.",i0)') id
  ! info ...
  write (logfu,'("write messages to: ",a)') trim(logfile)
  ! reset to "random" file unit:
  logfu = 123+id
  ! open:
  open( unit=logfu, file=trim(logfile), status='replace', iostat=status )
  if ( status/=0 ) then
    write (*,'("opening log file for output:")')
    write (*,'("  unit : ",i6)') logfu
    write (*,'("  file : ",a)') trim(logfile)
    TRACEBACK; status=1; call Exit(status)
  end if
  ! also write CSO messages to this unit:
  call csod%SetLogging( status, unit=logfu )
  IF_NOT_OK_RETURN(status=1)
  
  !! OPTIONALLY: write CSO messages to seperate file:
  !write (logfile,'("cso.log.",i0)') id
  !! redirect:
  !call csod%SetLogging( status, file=logfile )
  !IF_NOT_OK_RETURN(status=1)

#else

  ! serial:
  npes = 1
  id   = 0

  ! init CSO module:
  call csod%Init( status )
  IF_NOT_OK_RETURN(status=1)
  
  !! OPTIONALLY: write messages to file:
  !logfile = 'tutorial.log'
  !! info ...
  !write (logfu,'("write messages to: ",a)') trim(logfile)
  !! reset to "random" file unit:
  !logfu = 123
  !! open:
  !open( unit=logfu, file=trim(logfile), status='replace', iostat=status )
  !if ( status/=0 ) then
  !  write (*,'("opening log file for output:")')
  !  write (*,'("  unit : ",i6)') logfu
  !  write (*,'("  file : ",a)') trim(logfile)
  !  TRACEBACK; status=1; call Exit(status)
  !end if
  !! also write CSO messages to this unit:
  !call csod%SetLogging( status, unit=logfu )
  !IF_NOT_OK_RETURN(status=1)
  
  !! OPTIONALLY: write CSO messages to seperate file:
  !logfile = 'cso.log'
  !! redirect:
  !call csod%SetLogging( status, file=logfile )
  !IF_NOT_OK_RETURN(status=1)

#endif

  ! info ...
  write (logfu,'(a,":")') rname
  write (logfu,'(a,": ** CSO Tutorial Adj Test **")') rname
  write (logfu,'(a,":")') rname


  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ! settings
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  ! input settings:
  rcfile = 'tutorial_oper_adj-test.rc'
  ! base of keywords in rcfile:
  rcbase = 'tutorial.S5p.no2'
  
  ! info ...
  write (logfu,'(a,": settings file: ",a)') rname, trim(rcfile)
  ! read:
  call rcf%Init( rcfile, status )
  IF_NOT_OK_RETURN(status=1)

  ! time range:
  call rcf%Get( 'tutorial.timerange.start', t1, status )
  IF_NOT_OK_RETURN(status=1)
  call rcf%Get( 'tutorial.timerange.end', t2, status )
  IF_NOT_OK_RETURN(status=1)

  ! timestep of 1 hour:
  dt = CSO_TimeDelta( hour=1 )
  
  ! domain:
  call rcf%Get( 'tutorial.domain.west', west, status )
  IF_NOT_OK_RETURN(status=1)
  call rcf%Get( 'tutorial.domain.east', east, status )
  IF_NOT_OK_RETURN(status=1)
  call rcf%Get( 'tutorial.domain.south', south, status )
  IF_NOT_OK_RETURN(status=1)
  call rcf%Get( 'tutorial.domain.north', north, status )
  IF_NOT_OK_RETURN(status=1)
  ! resolution:
  call rcf%Get( 'tutorial.grid.dlon', dlon, status )
  IF_NOT_OK_RETURN(status=1)
  call rcf%Get( 'tutorial.grid.dlat', dlat, status )
  IF_NOT_OK_RETURN(status=1)
  ! global grid size:
  gnlon = nint( ( east  - west  )/dlon )
  gnlat = nint( ( north - south )/dlat )
  ! info ...
  write (logfu,'(a,": global domain             : [",f8.2,",",f8.2,"] x [",f8.2,",",f8.2,"]")') rname, west, east, south, north
  write (logfu,'(a,":   grid resolution         : ",f8.2," x ",f8.2)') rname, dlon, dlat
  write (logfu,'(a,":   grid shape              : ",i6," x ",i6)') rname, gnlon, gnlat

  ! info ...
  write (logfu,'(a,": number of processors      : ",i0)') rname, npes
  write (logfu,'(a,":   processor id (0-based)  : ",i0)') rname, id

  ! define domain decomposition:
  select case ( npes ) 
    case ( 1 )
      ndomx = 1
      ndomy = 1
    case ( 2 )
      ndomx = 2
      ndomy = 1
    case ( 4 )
      ndomx = 2
      ndomy = 2
    case default
      write (logfu,'(a,": unsupported number of domains ",i0)') npes
      TRACEBACK; status=1; call Exit(status)
  end select
  ! info ...
  write (logfu,'(a,":   decompostion            : ",i0," x ",i0)') rname, ndomx, ndomy

  ! zero-based location of this cpu within decomposition:
  idomx = mod( id, ndomx )
  idomy = id / ndomx
  ! info ...
  write (logfu,'(a,":   domain id (0-based)     : ",i0," , ",i0)') rname, idomx, idomy

  ! sub-domain:
  dom_west  = west  +  idomx    * (east -west )/ndomx
  dom_east  = west  + (idomx+1) * (east -west )/ndomx
  dom_south = south +  idomy    * (north-south)/ndomy
  dom_north = south + (idomy+1) * (north-south)/ndomy
  ! info ...
  write (logfu,'(a,": local domain              : [",f8.2,",",f8.2,"] x [",f8.2,",",f8.2,"]")') &
                   rname, dom_west, dom_east, dom_south, dom_north

  ! local grid size:
  nlon = nint( ( dom_east  - dom_west  )/dlon )
  nlat = nint( ( dom_north - dom_south )/dlat )
  ! offset in global grid:
  dom_ilon0 = nint( ( dom_west  - west  )/dlon )
  dom_ilat0 = nint( ( dom_south - south )/dlat )
  ! info ...
  write (logfu,'(a,": grid resolution           : ",f8.2," x ",f8.2)') rname, dlon, dlat
  write (logfu,'(a,":   grid shape              : ",i6," x ",i6)') rname, nlon, nlat
  write (logfu,'(a,":   domain offset           : ",i6," x ",i6)') rname, dom_ilon0, dom_ilat0
  
  ! mapping level:
  call rcf%Get( 'tutorial.mapping.levels', mapping_levels, status )
  IF_NOT_OK_RETURN(status=1)
  
  ! init grid mapping using:
  ! - west and south bound of global(!) grid;
  ! - grid spacing;
  ! - local grid cell offset in global grid;
  ! - local grid shape
  ! - recursion level
  call GridMapping%Init( west , dlon, dom_ilon0, nlon, &
                         south, dlat, dom_ilat0, nlat, &
                         mapping_levels, status )
  IF_NOT_OK_RETURN(status=1)
  
  ! number of layers:
  nz = 10

  ! listing file:
  call rcf%Get( trim(rcbase)//'.listing', listing_filename, status )
  IF_NOT_OK_RETURN(status=1)
  
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ! begin
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  ! info ...
  write (logfu,'(a,": read listing file: ",a)') rname, trim(listing_filename)
  ! read listing file:
  call listing%Init( listing_filename, status )
  IF_NOT_OK_RETURN(status=1)
  !! show content:
  !call listing%Show( status )
  !IF_NOT_OK_RETURN(status=1)
  
  ! model concentration array:
  allocate( conc(nlon,nlat,nz,nmem), stat=status )
  IF_NOT_OK_RETURN(status=1)
  ! loop over cells:
  do ilat = 1, nlat
    do ilon = 1, nlon
      do iz = 1, nz
        ! first member; fill with gradient from south-west to north-east,
        ! decreasing to top, zero in top layer:
        conc(ilon,ilat,iz,1) = ( real(dom_ilon0+ilon)/real(gnlon) + &
                                 real(dom_ilat0+ilat)/real(gnlat)   ) * 0.2 &
                               * real(nz-iz)/real(nz)
        ! second member; other gradient:
        conc(ilon,ilat,iz,2) = ( 2.0 - real(dom_ilon0+ilon)/real(gnlon) - &
                                       real(dom_ilat0+ilat)/real(gnlat)   ) * 0.1 &
                               * real(nz-iz)/real(nz)
      end do
    end do
  end do
  ! assume volume mixing ratio ..
  conc_units = 'ppb'
  
  ! gradient array:
  allocate( grad(nlon,nlat,nz), stat=status )
  IF_NOT_OK_RETURN(status=1)
  
  ! model half-level pressures:
  allocate( hp(nlon,nlat,0:nz), stat=status )
  IF_NOT_OK_RETURN(status=1)
  ! from surface 1000 hPa to zero top:
  do iz = 0, nz
    hp(:,:,iz) = 1000e2 * real(nz-iz)/real(nz)  ! Pa
  end do
  ! pressure units ..
  hp_units = 'Pa'
  
  ! cloud cover with single layer
  allocate( cc(nlon,nlat,nz), stat=status )
  IF_NOT_OK_RETURN(status=1)
  cc = 0.0
  cc(:,:,4) = 1.0
  cc(:,:,5) = 0.2
  ! total cloud cover:
  allocate( tcc(nlon,nlat), stat=status )
  IF_NOT_OK_RETURN(status=1)
  tcc = maxval( cc, dim=3 )
  cc_units = '1'
  
  ! info ...
  write (logfu,'(a,": time range : [",a,",",a,"]")') rname, trim(Pretty(t1)), trim(Pretty(t2))
  
  ! time loop:
  t = t1
  do
    ! info ...
    write (logfu,'(a,": time : ",a)') rname, trim(Pretty(t))
    
    ! get name of CSO file for orbit with time average
    ! in interval around current time:
    call listing%SearchFile( t-0.5*dt, t+0.5*dt, 'aver', orbit_filename, status )
    IF_NOT_OK_RETURN(status=1)

    !! testing ...
    !if ( t%hour /= 11 ) orbit_filename = ''

    ! defined?
    if ( len_trim(orbit_filename) > 0 ) then
    
      ! info ..
      write (logfu,'(a,":  orbit file : ",a)') rname, trim(orbit_filename)
      
      ! ~ orbit data
      
      ! inititalize orbit data,
      ! read all footprints available in file:
      call sdata%Init( rcF, rcbase, orbit_filename, status )
      IF_NOT_OK_RETURN(status=1)
      
      ! obtain from the orbit:
      ! - number of footprints (global, all pixels in file)
      ! - pointers to arrays with footprint centers
      ! - pointers to arrays with footprint corners
      ! - pointer to to selection flags, should be used to select pixels overlapping with local domain
      call sdata%Get( status, nglb=nglb, &
                               glb_lon=glb_lon, glb_lat=glb_lat, &
                               glb_clons=glb_clons, glb_clats=glb_clats, &
                               glb_select=glb_select )
      IF_NOT_OK_RETURN(status=1)
      
      ! select pixels that overlap with local domain;
      ! loop over global pixels:
      do iglb = 1, nglb
        !!~ testing, select all:
        !glb_select(1:nglb) = .true.
        !!~ deceide if pixel center is part of local domain:
        !glb_select(iglb) = (glb_lon(iglb) >= dom_west ) .and. (glb_lon(iglb) <= dom_east ) .and. &
        !                   (glb_lat(iglb) >= dom_south) .and. (glb_lat(iglb) <= dom_north)
        !~ check if footprint overlaps (partly) with domain,
        !  and if it is entirely in global domain;
        !  use bounding box of footprint to check:
        glb_select(iglb) = (maxval(glb_clons(:,iglb)) >= dom_west ) .and. (minval(glb_clons(:,iglb)) <= dom_east ) .and. &
                           (maxval(glb_clats(:,iglb)) >= dom_south) .and. (minval(glb_clats(:,iglb)) <= dom_north) .and. &
                           (minval(glb_clons(:,iglb)) >=     west ) .and. (maxval(glb_clons(:,iglb)) <=     east ) .and. &
                           (minval(glb_clats(:,iglb)) >=     south) .and. (maxval(glb_clats(:,iglb)) <=     north)
      end do ! iglb
      
      ! read orbit, locally store only pixels that are flagged in 'glb_select'
      ! as having overlapping with this domain:
      call sdata%Read( rcF, rcbase, status )
      IF_NOT_OK_RETURN(status=1)
      
      ! ~ simulation
      
      ! obtain info on track:
      !  - number of local pixels
      call sdata%Get( status, npix=npix )
      IF_NOT_OK_RETURN(status=1)
      
      ! loop over ensemble members:
      do imem = 1, nmem
        ! initialize simulation state;
        ! optional arguments:
        !   description='long name'    : used for output attributes
        call sstate(imem)%Init( sdata, rcF, rcbase, status, &
                                 description='simulated retrievals' )
        IF_NOT_OK_RETURN(status=1)

        ! number of user defined dimensions:
        call sstate(imem)%Get( status, nudim=nudim )
        IF_NOT_OK_RETURN(status=1)
        ! loop:
        do iudim = 1, nudim
          ! get dimension name to be defined:
          call sstate(imem)%GetDim( iudim, status, name=udimname )
          IF_NOT_OK_RETURN(status=1)
          ! switch:
          select case ( trim(udimname) )
            !~ model layers:
            case ( 'model_layer' )
              ! define:
              call sstate(imem)%SetDim( udimname, nz, status )
              IF_NOT_OK_RETURN(status=1)
            !~ model layer interfaces:
            case ( 'model_layeri' )
              ! define:
              call sstate(imem)%SetDim( udimname, nz+1, status )
              IF_NOT_OK_RETURN(status=1)
            !~ unknown ...
            case default
              write (logfu,'("unsupported dimension `",a,"`")') trim(udimname)
              TRACEBACK; status=1; call Exit(status)
          end select
        end do ! idim

        ! dimension defined, allocate storage:
        call sstate(imem)%EndDef( status )
        IF_NOT_OK_RETURN(status=1)
        
      end do  ! imem

      ! any pixels?
      if ( npix > 0 ) then
      
        ! pointers to (*,pixel) arrays:
        ! - footprint centers  (not used, for inspiration ..)
        ! - footprint corners
        call sdata%Get( status, lons=lons, lats=lats, clons=clons, clats=clats )
        IF_NOT_OK_RETURN(status=1)

        ! info ...
        write (logfu,'(a,": compute mapping weights ...")') rname
        ! get pointers to mapping arrays for all pixels:
        ! - areas(1:npix)            : pixel area [m2]
        ! - iw0(1:npix), nw(1:npix)  : offset and number of elements in ii/jj/ww
        ! - ii(:), jj(:), ww(:)      : cell and weight arrays for mapping to footprint,
        call GridMapping%GetWeights( clons, clats, &
                                       areas, iw0, nw, ii, jj, ww, status )
        IF_NOT_OK_RETURN(status=1)

        ! info ...
        write (logfu,'(a,":   store ...")') rname
        ! store mapping weights, might be saved and used to create gridded averages;
        ! cell indices ii/jj need to be the global index numbers!
        call sdata%SetMapping( areas, nw, dom_ilon0+ii, dom_ilat0+jj, ww, status )
        IF_NOT_OK_RETURN(status=1)
        
        ! loop over members:
        do imem = 1, nmem

          ! number of user defined variables:
          call sstate(imem)%Get( status, nuvar=nuvar )
          IF_NOT_OK_RETURN(status=1)
          ! any user defined?
          if ( nuvar > 0 ) then

            ! storage for variable names and units:
            allocate( uvarnames(nuvar), stat=status )
            IF_NOT_OK_RETURN(status=1)
            allocate( uvarunits(nuvar), stat=status )
            IF_NOT_OK_RETURN(status=1)
            ! fill:
            call sstate(imem)%Get( status, uvarnames=uvarnames, uvarunits=uvarunits )
            IF_NOT_OK_RETURN(status=1)

            ! loop over variables:
            do iuvar = 1, nuvar
              ! info ..
              write (logfu,'(a,": user defined variable: ",a)') rname, trim(uvarnames(iuvar))
              ! switch:
              select case ( trim(uvarnames(iuvar)) )

                !~ model concentrations
                case ( 'mod_conc' )
                  ! check units:
                  if ( trim(uvarunits(iuvar)) /= trim(conc_units) ) then
                    write (logfu,'("ERROR - variable `",a,"` requires conversion to `",a,"` from `",a,"`")') &
                             trim(uvarnames(iuvar)), trim(uvarunits(iuvar)), trim(conc_units)
                    TRACEBACK; status=1; call Exit(status)
                  end if
                  ! get pointer to target array with shape (nz,npix):
                  call sstate(imem)%GetData( status, name=uvarnames(iuvar), data1=data1 )
                  IF_NOT_OK_RETURN(status=1)
                  ! loop over pixels:
                  do ipix = 1, npix
                    ! any source contributions?
                    if ( nw(ipix) > 0 ) then
                      ! init sum:
                      data1(:,ipix) = 0.0
                      ! loop over source contributions:
                      do iw = iw0(ipix)+1, iw0(ipix)+nw(ipix)
                        ! add contribution:
                        data1(:,ipix) = data1(:,ipix) + conc(ii(iw),jj(iw),:,imem) * ww(iw)/areas(ipix)
                      end do ! iw
                    end if ! nw > 0
                  end do ! ipix

                !~ model half-level pressures:
                case ( 'mod_hp' )
                  ! check units:
                  if ( trim(uvarunits(iuvar)) /= trim(hp_units) ) then
                    write (logfu,'("ERROR - variable `",a,"` requires conversion to `",a,"` from `",a,"`")') &
                             trim(uvarnames(iuvar)), trim(uvarunits(iuvar)), trim(hp_units)
                    TRACEBACK; status=1; call Exit(status)
                  end if
                  ! get pointer to target array with shape (nz,npix):
                  call sstate(imem)%GetData( status, name=uvarnames(iuvar), data1=data1 )
                  IF_NOT_OK_RETURN(status=1)
                  ! loop over pixels:
                  do ipix = 1, npix
                    ! any source contributions?
                    if ( nw(ipix) > 0 ) then
                      ! init sum:
                      data1(:,ipix) = 0.0
                      ! loop over source contributions:
                      do iw = iw0(ipix)+1, iw0(ipix)+nw(ipix)
                        ! add contribution:
                        data1(:,ipix) = data1(:,ipix) + hp(ii(iw),jj(iw),:) * ww(iw)/areas(ipix)
                      end do ! iw
                    end if ! nw > 0
                  end do ! ipix

                !~ cloud cover: total:
                case ( 'mod_tcc' )
                  ! check units:
                  if ( trim(uvarunits(iuvar)) /= trim(cc_units) ) then
                    write (logfu,'("ERROR - variable `",a,"` requires conversion to `",a,"` from `",a,"`")') &
                             trim(uvarnames(iuvar)), trim(uvarunits(iuvar)), trim(cc_units)
                    TRACEBACK; status=1; call Exit(status)
                  end if
                  ! get pointer to target array with shape (npix):
                  call sstate(imem)%GetData( status, name=uvarnames(iuvar), data0=data0 )
                  IF_NOT_OK_RETURN(status=1)
                  ! loop over pixels:
                  do ipix = 1, npix
                    ! any source contributions?
                    if ( nw(ipix) > 0 ) then
                      ! init sum:
                      data0(ipix) = 0.0
                      ! loop over source contributions:
                      do iw = iw0(ipix)+1, iw0(ipix)+nw(ipix)
                        ! add contribution:
                        data0(ipix) = data0(ipix) + tcc(ii(iw),jj(iw)) * ww(iw)/areas(ipix)
                      end do ! iw
                    end if ! nw > 0
                  end do ! ipix

                !~ cloud cover: profile:
                case ( 'mod_cc' )
                  ! check units:
                  if ( trim(uvarunits(iuvar)) /= trim(cc_units) ) then
                    write (logfu,'("ERROR - variable `",a,"` requires conversion to `",a,"` from `",a,"`")') &
                             trim(uvarnames(iuvar)), trim(uvarunits(iuvar)), trim(cc_units)
                    TRACEBACK; status=1; call Exit(status)
                  end if
                  ! get pointer to target array with shape (nz,npix):
                  call sstate(imem)%GetData( status, name=uvarnames(iuvar), data1=data1 )
                  IF_NOT_OK_RETURN(status=1)
                  ! loop over pixels:
                  do ipix = 1, npix
                    ! any source contributions?
                    if ( nw(ipix) > 0 ) then
                      ! init sum:
                      data1(:,ipix) = 0.0
                      ! loop over source contributions:
                      do iw = iw0(ipix)+1, iw0(ipix)+nw(ipix)
                        ! add contribution:
                        data1(:,ipix) = data1(:,ipix) + cc(ii(iw),jj(iw),:) * ww(iw)/areas(ipix)
                      end do ! iw
                    end if ! nw > 0
                  end do ! ipix

                !~
                case default
                  write (logfu,'("unsupported variable name `",a,"`")') trim(uvarnames(iuvar))
                  TRACEBACK; status=1; call Exit(status)
              end select

            end do ! user defined variables

            ! info ...
            write (logfu,'(a,": end ...")') rname

            ! clear:
            deallocate( uvarnames, stat=status )
            IF_NOT_OK_RETURN(status=1)
            deallocate( uvarunits, stat=status )
            IF_NOT_OK_RETURN(status=1)

          end if ! nuvar > 0
          
        end do  ! imem

      end if ! npix > 0
      
      ! ~ formula
      
      ! inquire info on pixels covering multiple domains,
      ! setup exchange parameters:
      call sdata%SetupExchange( status )
      IF_NOT_OK_RETURN(status=1)

      ! loop over members:
      do imem = 1, nmem
        ! exchange simulations:
        call sstate(imem)%Exchange( sdata, status )
        IF_NOT_OK_RETURN(status=1)
        ! apply formula: kernel convolution etc:
        call sstate(imem)%ApplyFormulas( sdata, status )
        IF_NOT_OK_RETURN(status=1)
      end do ! imem
      
      ! ~ put out
      
      ! target file for selected data:
      write (output_filename,'("CSO_output_",i4.4,2i2.2,"_",2i2.2,"_data.nc")') &
                 t%year, t%month, t%day, t%hour, t%minute
      ! setup gathering information, gather output arrays, write:
      call sdata%PutOut( output_filename, status )
      IF_NOT_OK_RETURN(status=1)
      
      ! loop over members:
      do imem = 1, nmem
        ! target file for simulation state:
        write (output_filename,'("CSO_output_",i4.4,2i2.2,"_",2i2.2,"_state",i0,".nc")') &
                   t%year, t%month, t%day, t%hour, t%minute, imem
        ! gether output arrays, write:
        call sstate(imem)%PutOut( sdata, output_filename, status )
        IF_NOT_OK_RETURN(status=1)
      end do ! imem
      
      ! ~ gradient

      ! info ...
      write (logfu,'(a,": compute gradient ...")') rname
      
      !
      ! simulation of profile over pixel:
      !     cprof(:,ipix) = cprof(:,ipix) + conc(ii(iw),jj(iw),:) * ww(iw)/areas(ipix)
      !
      ! distribute gradient profiles per pixel over grid cells:
      !     grad(ii(iw),jj(iw),:) = grad(ii(iw),jj(iw),:) + gprof(:,ipix) * ww(iw)/areas(ipix)
      !
      
      ! init gradient:
      grad = 0.0
      
      ! any pixel?
      if ( npix > 0 ) then
      
        ! use gradient forcing computed from first simulations:
        imem = 1
        ! get pointer to gradient array with shape (nz,npix):
        call sstate(imem)%GetData( status, name='mod_g', data1=data1 )
        IF_NOT_OK_RETURN(status=1)

        ! loop over pixels:
        do ipix = 1, npix
          ! any source contributions?
          if ( nw(ipix) > 0 ) then
            ! loop over source contributions:
            do iw = iw0(ipix)+1, iw0(ipix)+nw(ipix)
              ! add contribution:
              grad(ii(iw),jj(iw),:) = grad(ii(iw),jj(iw),:) + data1(:,ipix) * ww(iw)/areas(ipix)
            end do ! iw
          end if ! nw > 0
        end do ! ipix
        
      end if ! npix > 0
      
      ! ~ adjoint test

      ! info ...
      write (logfu,'(a,": adjoint tests ...")') rname
      
      ! total number of pixels over all domains:
      call sdata%Get( status, nout=nout, nretr=nretr, nlayer=nlayer )
      IF_NOT_OK_RETURN(status=1)
      ! info ...
      write (logfu,'(a,":   total number of unique pixels over all domains: ",i0)') rname, nout
      
      ! only if some pixels are available ...
      if ( nout > 0 ) then
            
        ! storage:
        if ( csoc%root ) then
          allocate( gdata1_z1(nz,nout), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_z2(nz,nout), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_xs1(nlayer,nout), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_xs2(nlayer,nout), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_ys1(nretr,nout), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_ys2(nretr,nout), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_eps(nretr,nout), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_f(nlayer,nout), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_g(nz,nout), stat=status )
          IF_NOT_OK_RETURN(status=1)
        else
          allocate( gdata1_z1(1,1), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_z2(1,1), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_xs1(1,1), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_xs2(1,1), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_ys1(1,1), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_ys2(1,1), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_eps(1,1), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_f(1,1), stat=status )
          IF_NOT_OK_RETURN(status=1)
          allocate( gdata1_g(1,1), stat=status )
          IF_NOT_OK_RETURN(status=1)
        end if

        ! Adjoint test:
        ! - forward simulations:
        !     ys1 = h(x1) = z0 + H x1
        !     ys2 = h(x2) = z0 + H x2
        ! - gradient:
        !     g = H^T f
        ! Then check if:
        !    g^T (x2-x1)  ==  f^T (ys2-ys1)

        ! loop over tests:
        do itest = 1, 4

          ! switch:
          select case ( itest )

            !~ horizontal mapping:
            !    "x"  conc   ->   H   ->  mod_conc   "z"
            !    "g"  grad   <-  H^T  <-  mod_g      "f"
            case ( 1 )

              ! info ...
              write (logfu,'(a,":    over horizontal mapping:")') rname
              ! gather profiles with shape (nz,npix):
              call sstate(1)%GatherData( sdata, status, name='mod_conc', gdata1=gdata1_z1 )
              IF_NOT_OK_RETURN(status=1)
              call sstate(2)%GatherData( sdata, status, name='mod_conc', gdata1=gdata1_z2 )
              IF_NOT_OK_RETURN(status=1)
              ! gather adjoint forcing with shape (nz,npix):
              call sstate(1)%GatherData( sdata, status, name='mod_g', gdata1=gdata1_g )
              IF_NOT_OK_RETURN(status=1)

              ! local dot product:
              gTdx = sum(  grad   * ( conc(:,:,:,2) - conc(:,:,:,1) ) )
              ! sum over domains:
              call csoc%AllReduce( 'sum', gTdx, status )
              IF_NOT_OK_RETURN(status=1)

              ! gathered on root only ..
              if ( csoc%root ) then
                fTdz = sum( gdata1_g * (     gdata1_z2  -     gdata1_z1  ) )
              end if

            !~ vertical mapping:
            !    "x"  mod_conc   ->   H   ->  xs   "z"
            !    "g"  mod_g      <-  H^T  <-  f    "f"
            case ( 2 )

              ! info ...
              write (logfu,'(a,":    over vertical mapping:")') rname
              ! gather profiles with shape (nz,npix):
              call sstate(1)%GatherData( sdata, status, name='mod_conc', gdata1=gdata1_z1 )
              IF_NOT_OK_RETURN(status=1)
              call sstate(2)%GatherData( sdata, status, name='mod_conc', gdata1=gdata1_z2 )
              IF_NOT_OK_RETURN(status=1)
              ! gather profiles with shape (nlayer,npix):
              call sstate(1)%GatherData( sdata, status, name='xs', gdata1=gdata1_xs1 )
              IF_NOT_OK_RETURN(status=1)
              call sstate(2)%GatherData( sdata, status, name='xs', gdata1=gdata1_xs2 )
              IF_NOT_OK_RETURN(status=1)
              ! gather adjoint forcing with shape (nlayer,npix):
              call sstate(1)%GatherData( sdata, status, name='f', gdata1=gdata1_f )
              IF_NOT_OK_RETURN(status=1)
              ! gather adjoint forcing with shape (nz,npix):
              call sstate(1)%GatherData( sdata, status, name='mod_g', gdata1=gdata1_g )
              IF_NOT_OK_RETURN(status=1)

              ! gathered on root only ..
              if ( csoc%root ) then
                gTdx = sum( gdata1_g * ( gdata1_z2  - gdata1_z1  ) )
                fTdz = sum( gdata1_f * ( gdata1_xs2 - gdata1_xs1 ) )
              end if

            !~ kernel:
            !    "x"  xs  ->   A   ->  ys    "z"
            !    "g"  f   <-  A^T  <-  eps   "f"
            case ( 3 )

              ! info ...
              write (logfu,'(a,":    over kernel application:")') rname
              ! gather input with shape (nlayer,npix):
              call sstate(1)%GatherData( sdata, status, name='xs', gdata1=gdata1_xs1 )
              IF_NOT_OK_RETURN(status=1)
              call sstate(2)%GatherData( sdata, status, name='xs', gdata1=gdata1_xs2 )
              IF_NOT_OK_RETURN(status=1)
              ! gather output with shape (retr,npix):
              call sstate(1)%GatherData( sdata, status, name='ys', gdata1=gdata1_ys1 )
              IF_NOT_OK_RETURN(status=1)
              call sstate(2)%GatherData( sdata, status, name='ys', gdata1=gdata1_ys2 )
              IF_NOT_OK_RETURN(status=1)
              ! gather adjoint forcing with shape (retr,npix):
              call sstate(1)%GatherData( sdata, status, name='eps', gdata1=gdata1_eps )
              IF_NOT_OK_RETURN(status=1)
              ! gather gradient with shape (nlayer,npix):
              call sstate(1)%GatherData( sdata, status, name='f', gdata1=gdata1_f )
              IF_NOT_OK_RETURN(status=1)

              ! gathered on root only ..
              if ( csoc%root ) then
                gTdx = sum( gdata1_f   * ( gdata1_xs2 - gdata1_xs1 ) )
                fTdz = sum( gdata1_eps * ( gdata1_ys2 - gdata1_ys1  ) )
              end if

            !~ entire simulation
            !    "x"  conc  ->     H V A      ->  ys    "z"
            !    "g"  grad  <-  A^T V^T H^T   <-  eps   "f"
            case ( 4 )

              ! info ...
              write (logfu,'(a,":    over retrieval simulation:")') rname

              ! gather simulated retrievals with shape (retr,npix):
              call sstate(1)%GatherData( sdata, status, name='ys', gdata1=gdata1_ys1 )
              IF_NOT_OK_RETURN(status=1)
              call sstate(2)%GatherData( sdata, status, name='ys', gdata1=gdata1_ys2 )
              IF_NOT_OK_RETURN(status=1)
              ! gather adjoint forcing with shape (retr,npix):
              call sstate(1)%GatherData( sdata, status, name='eps', gdata1=gdata1_eps )
              IF_NOT_OK_RETURN(status=1)

              ! local dot product:
              gTdx = sum( grad  * ( conc(:,:,:,2) - conc(:,:,:,1) ) )
              ! sum over domains:
              call csoc%AllReduce( 'sum', gTdx, status )
              IF_NOT_OK_RETURN(status=1)

              ! gathered on root only ..
              if ( csoc%root ) then
                fTdz = sum( gdata1_eps * (   gdata1_ys2  -  gdata1_ys1  ) )
              end if

            !~
            case default
              write (logfu,'("ERROR - unsupported test ",i0)') itest
              TRACEBACK; status=1; call Exit(status)
          end select

          ! show on root:
          if ( csoc%root ) then
            aver  = abs( fTdz + gTdx )/2.0
            adiff = abs(fTdz-gTdx)
            write (logfu,'(a,":     g^T (x2-x1) = ",es16.8)') rname, gTdx
            write (logfu,'(a,":     f^T (z2-z1) = ",es16.8)') rname, fTdz
            write (logfu,'(a,":     abs.diff    = ",es16.8)') rname, adiff
            if ( aver > 0.0 ) then
              rdiff = adiff / aver
              write (logfu,'(a,":     rel.diff    = ",es16.8)') rname, rdiff
            else
              write (logfu,'(a,":     rel.diff    =              Inf")') rname
            end if
          end if

        end do  ! itest

        ! clear:
        deallocate( gdata1_z1, stat=status )
        IF_NOT_OK_RETURN(status=1)
        deallocate( gdata1_z2, stat=status )
        IF_NOT_OK_RETURN(status=1)
        deallocate( gdata1_xs1, stat=status )
        IF_NOT_OK_RETURN(status=1)
        deallocate( gdata1_xs2, stat=status )
        IF_NOT_OK_RETURN(status=1)
        deallocate( gdata1_ys1, stat=status )
        IF_NOT_OK_RETURN(status=1)
        deallocate( gdata1_ys2, stat=status )
        IF_NOT_OK_RETURN(status=1)
        deallocate( gdata1_eps, stat=status )
        IF_NOT_OK_RETURN(status=1)
        deallocate( gdata1_f, stat=status )
        IF_NOT_OK_RETURN(status=1)
        deallocate( gdata1_g, stat=status )
        IF_NOT_OK_RETURN(status=1)
        
      end if  ! nout > 0

      ! ~ clear
      
      ! clear:
      nullify( glb_lon )
      nullify( glb_lat )
      nullify( glb_select )
      
      ! loop over members:
      do imem = 1, nmem
        ! done with state:
        call sstate(imem)%Done( sdata, status )
        IF_NOT_OK_RETURN(status=1)
      end do
      
      ! done with data:
      call sdata%Done( status )
      IF_NOT_OK_RETURN(status=1)
      
      !! testing ...
      !write (logfu,'("break after first orbit")')
      !exit

    end if  ! orbit found in listing
    
    ! end?
    if ( t >= t2 ) exit
    ! next:
    t = t + dt
  end do ! time loop

  ! done with listing:
  call listing%Done( status )
  IF_NOT_OK_RETURN(status=1)
  
  ! done with grid mapping:
  call GridMapping%Done( status )
  IF_NOT_OK_RETURN(status=1)
  
  ! done with gradient array:
  deallocate( grad, stat=status )
  IF_NOT_OK_RETURN(status=1)
  
  ! done with model arrays:
  deallocate( conc, stat=status )
  IF_NOT_OK_RETURN(status=1)
  deallocate( hp, stat=status )
  IF_NOT_OK_RETURN(status=1)
  
  ! clear:
  deallocate( cc, stat=status )
  IF_NOT_OK_RETURN(status=1)
  deallocate( tcc, stat=status )
  IF_NOT_OK_RETURN(status=1)

  
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ! done with settings
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  ! done with settings:
  call rcf%Done( status )
  IF_NOT_OK_RETURN(status=1)

  
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ! done
  !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  ! done with CSO:
  call csod%Done( status )
  IF_NOT_OK_RETURN(status=1)

#ifdef _MPI
  ! done with MPI interface:
  call MPI_Finalize( ierror=status )
  if ( status /= MPI_SUCCESS ) then
    write (logfu,'("could not finalize MPI environment; exit code : ",i6)') status
    TRACEBACK; status=1; call Exit(status)
  end if
#endif

  ! info ...
  write (logfu,'(a,":")') rname
  write (logfu,'(a,": ** end **")') rname
  write (logfu,'(a,":")') rname

end program Tutorial_Oper_Adj_Test


