      subroutine putdat(flnm, artype,time,
     &                  lsteric,icegln,trcout,
     &                  iexpt,iversn,yrflag,kkout, thbase)
      use mod_mom6  ! HYCOM mom6 array interface
      use mod_za    ! HYCOM array I/O interface
c
      character        flnm*(*)
      double precision time(3)
      real             thbase
      integer          artype,iexpt,iversn,yrflag,kkout
      logical          lsteric,icegln,trcout
c
c --- write model fields.
c --- HYCOM 2.0 array I/O archive file.
c
      character*8 ctype
c
      real      coord,xmin,xmax
      integer   i,j,k,ktr,jversn,l,nop
      data nop/24/
c
c
c ---   output is in "*.[ab]"
c
      l = len_trim(flnm)
      if     (flnm(l-1:l).eq.'.a' .or. flnm(l-1:l).eq.'.b') then
        open (unit=nop,file=flnm(1:l-2)//'.b',form='formatted',
     &          status='new',action='write')
        call zaiopf(flnm(1:l-2)//'.a','new', nop)
      else
        open (unit=nop,file=flnm(1:l)//'.b',form='formatted',
     &          status='new',action='write')
        call zaiopf(flnm(1:l)//'.a','new', nop)
      endif
c
c --- header.
c
      jversn = max(iversn,20)
      if     (artype.eq.1) then
        write(nop,116) ctitle,jversn,iexpt,yrflag,idm,jdm
        write( lp,  *)
        write( lp,116) ctitle,jversn,iexpt,yrflag,idm,jdm
 116    format (a80/a80/a80/a80/
     &   i5,4x,'''iversn'' = hycom version number x10'/
     &   i5,4x,'''iexpt '' = experiment number x10'/
     &   i5,4x,'''yrflag'' = days in year flag'/
     &   i5,4x,'''idm   '' = longitudinal array size'/
     &   i5,4x,'''jdm   '' = latitudinal  array size'/
     &   'field       time step  model day',
     &   '  k  dens        min              max')
      elseif (artype.eq.2) then
        write(nop,118) ctitle,jversn,iexpt,yrflag,idm,jdm
        write( lp,  *)
        write( lp,118) ctitle,jversn,iexpt,yrflag,idm,jdm
 118    format (a80/a80/a80/a80/
     &   i5,4x,'''iversn'' = hycom version number x10'/
     &   i5,4x,'''iexpt '' = experiment number x10'/
     &   i5,4x,'''yrflag'' = days in year flag'/
     &   i5,4x,'''idm   '' = longitudinal array size'/
     &   i5,4x,'''jdm   '' = latitudinal  array size'/
     &   'field         no. recs  mean day',
     &   '  k  dens        min              max')
      else
        write( lp,"(/ a /)")
     &    'error in putdat - only artpe==1 and artype==2 allowed'
        stop
      endif

c
c --- surface fields.
c
      coord=0.0
c
      call zaiowr(montg,ip,.true.,
     &            xmin,xmax, nop, .false.)
      if     (sigver.gt.0) then
c ---   identify the equation of state on the first record
        write (nop,117) 'montg1  ',nstep,time(1),sigver,thbase,xmin,xmax
        call flush(nop)
        write ( lp,117) 'montg1  ',nstep,time(1),sigver,thbase,xmin,xmax
        call flush( lp)
      else
        write (nop,117) 'montg1  ',nstep,time(1),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'montg1  ',nstep,time(1),0,coord,xmin,xmax
        call flush( lp)
      endif !sigver
      call zaiowr(srfht,ip,.true.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'srfhgt  ',nstep,time(2),0,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'srfhgt  ',nstep,time(2),0,coord,xmin,xmax
      call flush( lp)
c
      if(lsteric) then
        call zaiowr(steric,ip,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'steric  ',nstep,time(3),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'steric  ',nstep,time(3),0,coord,xmin,xmax
        call flush( lp)
      endif
c
      call zaiowr(surflx,ip,.true., xmin,xmax, nop, .false.)
      write (nop,117) 'surflx  ',nstep,time(3),0,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'surflx  ',nstep,time(3),0,coord,xmin,xmax
      call flush( lp)
      call zaiowr(salflx,ip,.true., xmin,xmax, nop, .false.)
      write (nop,117) 'salflx  ',nstep,time(3),0,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'salflx  ',nstep,time(3),0,coord,xmin,xmax
      call flush( lp)
c
      call zaiowr(dpbl,ip,.true., xmin,xmax, nop, .false.)
      write (nop,117) 'bl_dpth ',nstep,time(3),0,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'bl_dpth ',nstep,time(3),0,coord,xmin,xmax
      call flush( lp)
      call zaiowr(dpmixl,ip,.true.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'mix_dpth',nstep,time(3),0,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'mix_dpth',nstep,time(3),0,coord,xmin,xmax
      call flush( lp)
      if     (sigver.eq.0) then
        call zaiowr(tmix,ip,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'tmix    ',nstep,time(3),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'tmix    ',nstep,time(3),0,coord,xmin,xmax
        call flush( lp)
        call zaiowr(smix,ip,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'smix    ',nstep,time(3),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'smix    ',nstep,time(3),0,coord,xmin,xmax
        call flush( lp)
        call zaiowr(thmix,ip,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'thmix   ',nstep,time(3),0,thbase,xmin,xmax
        call flush(nop)
        write ( lp,117) 'thmix   ',nstep,time(3),0,thbase,xmin,xmax
        call flush( lp)
        call zaiowr(umix,iu,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'umix    ',nstep,time(3),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'umix    ',nstep,time(3),0,coord,xmin,xmax
        call flush( lp)
        call zaiowr(vmix,iv,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'vmix    ',nstep,time(3),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'vmix    ',nstep,time(3),0,coord,xmin,xmax
        call flush( lp)
      endif !sigver==0
      if(artype.gt.1) then
        call zaiowr(kemix, ip,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'kemix   ',nstep,time(3),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'kemix   ',nstep,time(3),0,coord,xmin,xmax
        call flush( lp)
      endif
      if(icegln) then
        call zaiowr(covice,ip,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'covice  ',nstep,time(3),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'covice  ',nstep,time(3),0,coord,xmin,xmax
        call flush( lp)
        call zaiowr(thkice,ip,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'thkice  ',nstep,time(3),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'thkice  ',nstep,time(3),0,coord,xmin,xmax
        call flush( lp)
        call zaiowr(temice,ip,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'temice  ',nstep,time(3),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'temice  ',nstep,time(3),0,coord,xmin,xmax
        call flush( lp)
      endif
c
c --- depth averaged fields (no mask, in case this is a subregion archive).
c
      call zaiowr(ubaro,iu,.false.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'u_btrop ',nstep,time(3),0,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'u_btrop ',nstep,time(3),0,coord,xmin,xmax
      call flush( lp)
      call zaiowr(vbaro,iv,.false.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'v_btrop ',nstep,time(3),0,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'v_btrop ',nstep,time(3),0,coord,xmin,xmax
      call flush( lp)
      if(artype.gt.1) then
        call zaiowr(kebaro,ip,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'kebtrop ',nstep,time(3),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'kebtrop ',nstep,time(3),0,coord,xmin,xmax
        call flush( lp)
      endif
c
c --- layer loop.
c
      do 75 k=1,kkout
      coord=theta(k)
      call zaiowr(u(1,1,k),iu,.true.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'u-vel.  ',nstep,time(3),k,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'u-vel.  ',nstep,time(3),k,coord,xmin,xmax
      call flush( lp)
      call zaiowr(v(1,1,k),iv,.true.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'v-vel.  ',nstep,time(3),k,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'v-vel.  ',nstep,time(3),k,coord,xmin,xmax
      call flush( lp)
      if(artype.gt.1) then
        call zaiowr(ke(1,1,k),ip,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'k.e.    ',nstep,time(3),k,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'k.e.    ',nstep,time(3),k,coord,xmin,xmax
        call flush( lp)
      endif
      call zaiowr(dp(1,1,k),  ip,.true.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'thknss  ',nstep,time(3),k,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'thknss  ',nstep,time(3),k,coord,xmin,xmax
      call flush( lp)
      call zaiowr(temp(1,1,k),ip,.true.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'temp    ',nstep,time(3),k,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'temp    ',nstep,time(3),k,coord,xmin,xmax
      call flush( lp)
      call zaiowr(saln(1,1,k),ip,.true.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'salin   ',nstep,time(3),k,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'salin   ',nstep,time(3),k,coord,xmin,xmax
      call flush( lp)
      if     (sigver.eq.0) then
        call zaiowr(th3d(1,1,k),ip,.true.,
     &              xmin,xmax, nop, .false.)
        write (nop,117) 'density ',nstep,time(3),k,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'density ',nstep,time(3),k,coord,xmin,xmax
        call flush( lp)
      endif !sigver==0
      if     (trcout) then
        do ktr= 1,ntracr
          call zaiowr(trcr(1,1,k,ktr),ip,.true.,
     &                xmin,xmax, nop, .false.)
          if     (ktr.le.99) then
c ---       older postprocessing code will not recognise this
            write(ctype,'(a6,i2.2)') 'tracer',ktr
          else
            ctype = 'tracer  '
          endif
          write (nop,117) ctype,nstep,time(3),k,coord,xmin,xmax
          call flush(nop)
          write ( lp,117) ctype,nstep,time(3),k,coord,xmin,xmax
          call flush( lp)
        enddo !ktr
      endif !trcout
 75   continue
c
 117  format (a8,' =',i11,f11.3,i3,f7.3,1p2e16.7)
c
      close (unit=nop)
      call zaiocl(nop)
      return
      end

      subroutine putdat_tide(flnm, artype,time,lsteric,
     &                       iexpt,iversn,yrflag, thbase)
      use mod_mom6  ! HYCOM mom6 array interface
      use mod_za    ! HYCOM array I/O interface
c
      character        flnm*(*)
      double precision time(3)
      real             thbase
      integer          artype,iexpt,iversn,yrflag
      logical          lsteric
c
c --- write model fields.
c --- HYCOM 2.0 array I/O archive file.
c
      character*8 ctype
c
      real      coord,xmin,xmax
      integer   i,j,k,ktr,jversn,l,nop
      data nop/24/
c
c
c ---   output is in "*.[ab]"
c
      l = len_trim(flnm)
      if     (flnm(l-1:l).eq.'.a' .or. flnm(l-1:l).eq.'.b') then
        open (unit=nop,file=flnm(1:l-2)//'.b',form='formatted',
     &          status='new',action='write')
        call zaiopf(flnm(1:l-2)//'.a','new', nop)
      else
        open (unit=nop,file=flnm(1:l)//'.b',form='formatted',
     &          status='new',action='write')
        call zaiopf(flnm(1:l)//'.a','new', nop)
      endif
c
c --- header.
c
      jversn = max(iversn,20)
      if     (artype.eq.1) then
        write(nop,116) ctitle,jversn,iexpt,yrflag,idm,jdm
        write( lp,  *)
        write( lp,116) ctitle,jversn,iexpt,yrflag,idm,jdm
 116    format (a80/a80/a80/a80/
     &   i5,4x,'''iversn'' = hycom version number x10'/
     &   i5,4x,'''iexpt '' = experiment number x10'/
     &   i5,4x,'''yrflag'' = days in year flag'/
     &   i5,4x,'''idm   '' = longitudinal array size'/
     &   i5,4x,'''jdm   '' = latitudinal  array size'/
     &   'field       time step  model day',
     &   '  k  dens        min              max')
      elseif (artype.eq.2) then
        write(nop,118) ctitle,jversn,iexpt,yrflag,idm,jdm
        write( lp,  *)
        write( lp,118) ctitle,jversn,iexpt,yrflag,idm,jdm
 118    format (a80/a80/a80/a80/
     &   i5,4x,'''iversn'' = hycom version number x10'/
     &   i5,4x,'''iexpt '' = experiment number x10'/
     &   i5,4x,'''yrflag'' = days in year flag'/
     &   i5,4x,'''idm   '' = longitudinal array size'/
     &   i5,4x,'''jdm   '' = latitudinal  array size'/
     &   'field         no. recs  mean day',
     &   '  k  dens        min              max')
      else
        write( lp,"(/ a /)")
     &    'error in putdat - only artpe==1 and artype==2 allowed'
        stop
      endif

c
c --- surface fields.
c
      coord=0.0
c
      call zaiowr(montg,ip,.true.,
     &            xmin,xmax, nop, .false.)
      if     (sigver.gt.0) then
c ---   identify the equation of state on the first record
        write (nop,117) 'montg1  ',nstep,time(1),sigver,thbase,xmin,xmax
        call flush(nop)
        write ( lp,117) 'montg1  ',nstep,time(1),sigver,thbase,xmin,xmax
        call flush( lp)
      else
        write (nop,117) 'montg1  ',nstep,time(1),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'montg1  ',nstep,time(1),0,coord,xmin,xmax
        call flush( lp)
      endif !sigver
      call zaiowr(srfht,ip,.true.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'srfhgt  ',nstep,time(2),0,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'srfhgt  ',nstep,time(2),0,coord,xmin,xmax
      call flush( lp)
c
      if(lsteric) then
        call zaiowr(steric,ip,.true., xmin,xmax, nop, .false.)
        write (nop,117) 'steric  ',nstep,time(3),0,coord,xmin,xmax
        call flush(nop)
        write ( lp,117) 'steric  ',nstep,time(3),0,coord,xmin,xmax
        call flush( lp)
      endif
c
c --- depth averaged fields (no mask, in case this is a subregion archive).
c
      call zaiowr(ubaro,iu,.false.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'u_btrop ',nstep,time(3),0,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'u_btrop ',nstep,time(3),0,coord,xmin,xmax
      call flush( lp)
      call zaiowr(vbaro,iv,.false.,
     &            xmin,xmax, nop, .false.)
      write (nop,117) 'v_btrop ',nstep,time(3),0,coord,xmin,xmax
      call flush(nop)
      write ( lp,117) 'v_btrop ',nstep,time(3),0,coord,xmin,xmax
      call flush( lp)
c
 117  format (a8,' =',i11,f11.3,i3,f7.3,1p2e16.7)
c
      close (unit=nop)
      call zaiocl(nop)
      return
      end


SUBROUTINE prepare_databases ( &
     xtrack_pix, n_sol_wvl, sol_wvl, sol_spc, n_rad_wvl, curr_rad_wvl, n_max_rspec, errstat )

  ! ===========================================
  !
  ! Called from XTRACK_RADIANCE_WVL_CALIBRATION
  !
  ! ===========================================

  USE OMSAO_precision_module
  USE OMSAO_variables_module, ONLY: hw1e, e_asym, phase, have_undersampling, database
  USE OMSAO_errstat_module
  IMPLICIT NONE

  ! ---------------
  ! Input variables
  ! ---------------
  INTEGER (KIND=i4),                        INTENT (IN) :: xtrack_pix, n_rad_wvl, n_sol_wvl, n_max_rspec
  REAL    (KIND=r8), DIMENSION (n_rad_wvl), INTENT (IN) :: curr_rad_wvl
  REAL    (KIND=r8), DIMENSION (n_sol_wvl), INTENT (IN) :: sol_wvl, sol_spc

  ! ---------------
  ! Output variable
  ! ---------------
  INTEGER (KIND=i4), INTENT (INOUT) :: errstat

  ! ---------------
  ! Local variables
  ! ---------------
  INTEGER (KIND=i4) :: locerrstat

  locerrstat = pge_errstat_ok

  ! ---------------------------------------------------------
  ! Spline external reference spectra to common radiance grid
  ! ---------------------------------------------------------
  CALL dataspline ( xtrack_pix, n_rad_wvl, curr_rad_wvl(1:n_rad_wvl), n_max_rspec, locerrstat )
  errstat = MAX ( errstat, locerrstat )
  IF ( errstat >= pge_errstat_error ) RETURN

  ! -----------------------------------
  ! Calculate the undersampled spectrum
  ! -----------------------------------
  IF ( ANY (have_undersampling) ) &
       CALL undersample (                                                               &
       xtrack_pix, n_rad_wvl, curr_rad_wvl(1:n_rad_wvl), hw1e, e_asym, phase, locerrstat )
  errstat = MAX ( errstat, locerrstat )
  IF ( errstat >= pge_errstat_error ) RETURN
  !IF ( ANY (have_undersampling) ) &
  !     CALL undersample_new (                                                             &
  !     xtrack_pix, n_rad_wvl, curr_rad_wvl(1:n_rad_wvl), n_sol_wvl, sol_wvl(1:n_sol_wvl), &
  !     hw1e, e_asym, locerrstat )
  !errstat = MAX ( errstat, locerrstat )
  !IF ( errstat >= pge_errstat_error ) RETURN

  ! -------------------------------------------------------------------------------------
  ! Calculate the splined fitting database. This will be saved into a nXtrack-dimensional
  ! array in a calling routine higher up (inside the fitting loop).
  ! -------------------------------------------------------------------------------------
  CALL prepare_solar_refspec ( &
       n_sol_wvl, sol_wvl(1:n_sol_wvl), sol_spc(1:n_sol_wvl), n_rad_wvl, &
       curr_rad_wvl(1:n_rad_wvl), locerrstat )
  errstat = MAX ( errstat, locerrstat )
  IF ( errstat >= pge_errstat_error ) RETURN

  RETURN
END SUBROUTINE prepare_databases

SUBROUTINE prepare_solar_refspec ( &
     n_solpts, sol_wvl, sol_spc, n_radpts, curr_rad_wvl, errstat )

  ! ***********************************************************
  !
  !   Spline the solar measured solar spectrum to the radiance
  !   wavelength grid
  !
  !   Called from PREPARE_DATABASE
  !
  ! ***********************************************************

  USE OMSAO_precision_module
  USE OMSAO_indices_module,    ONLY: &
       max_rs_idx, solar_idx, ring_idx, wvl_idx, spc_idx
  USE OMSAO_parameters_module, ONLY: maxchlen
  USE OMSAO_variables_module,  ONLY: yn_doas, fit_winwav_idx, yn_smooth, n_refspec, database
  USE OMSAO_errstat_module

  IMPLICIT NONE

  ! ---------------
  ! Input variables
  ! ---------------
  INTEGER (KIND=i4),                       INTENT (IN)    :: n_radpts, n_solpts
  REAL    (KIND=r8), DIMENSION (n_solpts), INTENT (IN)    :: sol_wvl, sol_spc
  REAL    (KIND=r8), DIMENSION (n_radpts), INTENT (IN)    :: curr_rad_wvl
  INTEGER (KIND=i4),                       INTENT (INOUT) :: errstat

  ! ---------------
  ! Local variables
  ! ---------------
  LOGICAL                                 :: yn_full_range
  INTEGER (KIND=i4)                       :: j, ll_rad, lu_rad, locerrstat, n_sol_tmp
  REAL    (KIND=r8), DIMENSION (n_radpts) :: spline_sun
  REAL    (KIND=r8), DIMENSION (n_solpts) :: tmp_sol_spec, tmp_sol_wvl

  ! ------------------------------
  ! Name of this subroutine/module
  ! ------------------------------
  CHARACTER (LEN=21), PARAMETER :: modulename = 'prepare_solar_refspec'

  locerrstat = pge_errstat_ok

  ! ---------------------------------------------
  ! Spline irradiance spectrum onto radiance grid
  ! ---------------------------------------------
  ! There are two issues here:
  ! * The radiance and irradiance grids are likely to be off-set, i.e., at one
  !   or both end points we will run into an extrapolation.
  ! * Any bad pixel in the solar spectrum must be avoided in the interpolation.

  ! ----------------------------------------------------------------------
  ! First create an array with solar spectrum and wavelengths that is free
  ! of any bad pixels. "Bad" pixels are set to -1.0_r8
  ! ----------------------------------------------------------------------
  n_sol_tmp = 0
  DO j = 1, n_solpts
     IF ( sol_spc(j) > 0.0_r8 ) THEN
        n_sol_tmp = n_sol_tmp + 1
        tmp_sol_wvl (n_sol_tmp) = sol_wvl(j)
        tmp_sol_spec(n_sol_tmp) = sol_spc(j)
        ! ------------------------------------------------
        ! Check whether wavelengths are strictly ascending
        ! ------------------------------------------------
        IF ( n_sol_tmp > 1 ) THEN
           IF ( tmp_sol_wvl (n_sol_tmp) <= tmp_sol_wvl (n_sol_tmp-1) ) n_sol_tmp = n_sol_tmp - 1
        END IF
     END IF
  END DO

  ! ----------------------------------------------------------------
  ! Interpolate (spectral overlap is taken care of in INTERPOLATION)
  ! ----------------------------------------------------------------
  CALL interpolation ( &
       modulename,                                                                 &
       n_sol_tmp, tmp_sol_wvl(1:n_sol_tmp), tmp_sol_spec(1:n_sol_tmp),             &
       n_radpts, curr_rad_wvl(1:n_radpts), spline_sun(1:n_radpts),                 &
       'endpoints', 0.0_r8, yn_full_range, locerrstat )
  CALL error_check ( &
       locerrstat, pge_errstat_ok, pge_errstat_error, OMSAO_E_INTERPOL, &
       modulename, vb_lev_default, errstat )
  IF ( errstat >= pge_errstat_error ) RETURN
  IF ( .NOT. yn_full_range )   CALL error_check ( 0, 1, pge_errstat_warning, &
       OMSAO_W_INTERPOL_RANGE, modulename, vb_lev_develop, errstat )

  ! --------------------------------------------------------------------------
  ! Finally, we have to check whether we encountered any bad solar pixels. The
  ! adopted strategy is to exclude any such pixels from the fit, plus a window
  ! of +/- 0.1 nm around them.
  ! --------------------------------------------------------------------------
  DO j = 1, n_solpts
     IF ( sol_spc(j) < 0.0_r8 ) THEN
        WHERE ( ABS(curr_rad_wvl(1:n_radpts)-sol_wvl(j)) <= 0.1_r8)
           spline_sun(1:n_radpts) = -1.0_r8
        END WHERE
     END IF
  END DO

  ! --------------------------------------------------------
  ! Now we are ready to assign the splined solar spectrum to
  ! its final array - DATABASE(solar_idx,*).
  ! --------------------------------------------------------
  database(solar_idx,1:n_radpts) = spline_sun(1:n_radpts)

  ! =================================================================
  ! Note that the UNDERSAMPLING spectrum has already been assigned to
  ! DATABASE(us1/2_idx,*) in the UNDERSPEC routine.
  ! =================================================================

  ! ---------------------------------------------------------------------
  ! Set up Ring spectrum for high pass filtering of divided spectrum
  ! (afterward, add solar spectrum back in order to divide by solar
  ! spectrum with altered wavelength calibration in subroutine spectrum).
  ! ---------------------------------------------------------------------
  IF ( yn_doas ) database(ring_idx, 1:n_radpts) = &
       database(ring_idx, 1:n_radpts) / spline_sun(1:n_radpts)

  ! ---------------------------------------------------------
  ! For the DOAS case, high-pass filter the reference spectra
  ! ---------------------------------------------------------
  IF ( yn_doas ) THEN
     ll_rad = fit_winwav_idx(2) ; lu_rad = fit_winwav_idx(3)
     CALL subtract_cubic (curr_rad_wvl, n_radpts, ll_rad, lu_rad)
     database(ring_idx, 1:n_radpts) = &
          database(ring_idx, 1:n_radpts) * spline_sun(1:n_radpts)
  END IF

  IF ( yn_smooth ) database(1:max_rs_idx, 3:n_radpts-2) = &
       0.375_r8  * database(1:max_rs_idx, 3:n_radpts-2)  +  &
       0.25_r8   * (database(1:max_rs_idx, 4:n_radpts-1) + &
       database(1:max_rs_idx, 2:n_radpts-3)) + &
       0.0625_r8 * (database(1:max_rs_idx, 5:n_radpts)   + &
       database(1:max_rs_idx, 1:n_radpts-4))

  errstat = MAX ( errstat, locerrstat )

  RETURN
END SUBROUTINE prepare_solar_refspec


! KGEN-generated Fortran source file
!
! Filename    : rrlw_kg11.f90
! Generated at: 2015-07-06 23:28:45
! KGEN version: 0.4.13

    MODULE rrlw_kg11
        USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check
        USE shr_kind_mod, ONLY: r8 => shr_kind_r8
        !      use parkind ,only : jpim, jprb
        IMPLICIT NONE
        !-----------------------------------------------------------------
        ! rrtmg_lw ORIGINAL abs. coefficients for interval 11
        ! band 11:  1480-1800 cm-1 (low - h2o; high - h2o)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefao: real
        !fracrefbo: real
        ! kao     : real
        ! kbo     : real
        ! kao_mo2 : real
        ! kbo_mo2 : real
        ! selfrefo: real
        ! forrefo : real
        !-----------------------------------------------------------------
        !-----------------------------------------------------------------
        ! rrtmg_lw COMBINED abs. coefficients for interval 11
        ! band 11:  1480-1800 cm-1 (low - h2o; high - h2o)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefa : real
        !fracrefb : real
        ! ka      : real
        ! kb      : real
        ! ka_mo2  : real
        ! kb_mo2  : real
        ! selfref : real
        ! forref  : real
        !
        ! absa    : real
        ! absb    : real
        !-----------------------------------------------------------------
        INTEGER, parameter :: ng11 = 8
        REAL(KIND=r8), dimension(ng11) :: fracrefa
        REAL(KIND=r8), dimension(ng11) :: fracrefb
        REAL(KIND=r8) :: absa(65,ng11)
        REAL(KIND=r8) :: absb(235,ng11)
        REAL(KIND=r8) :: ka_mo2(19,ng11)
        REAL(KIND=r8) :: kb_mo2(19,ng11)
        REAL(KIND=r8) :: selfref(10,ng11)
        REAL(KIND=r8) :: forref(4,ng11)
        PUBLIC kgen_read_externs_rrlw_kg11
    CONTAINS

    ! write subroutines

    ! module extern variables

    SUBROUTINE kgen_read_externs_rrlw_kg11(kgen_unit)
        INTEGER, INTENT(IN) :: kgen_unit
        READ(UNIT=kgen_unit) fracrefa
        READ(UNIT=kgen_unit) fracrefb
        READ(UNIT=kgen_unit) absa
        READ(UNIT=kgen_unit) absb
        READ(UNIT=kgen_unit) ka_mo2
        READ(UNIT=kgen_unit) kb_mo2
        READ(UNIT=kgen_unit) selfref
        READ(UNIT=kgen_unit) forref
    END SUBROUTINE kgen_read_externs_rrlw_kg11

    END MODULE rrlw_kg11


C    %W% %G%
      subroutine rmsol
C
C     This subroutine contains the solution logic for the
C     underfrequency generator dropping relay.  It is called
C     by RELAY.
C
      include 'tspinc/params.inc'
      include 'tspinc/rmcom.inc'
      include 'tspinc/vrgov.inc'
      include 'tspinc/prate.inc'
      include 'tspinc/busvolt.inc'
      include 'tspinc/relays.inc'
      include 'tspinc/igentn.inc'
      include 'tspinc/param.inc'
      include 'tspinc/lnk12.inc'
      include 'tspinc/prt.inc'
      include 'tspinc/bname.inc'
      include 'tspinc/buskv.inc'

      dimension indt(2)
      character*8 name1c
      character*1 indc
      do i = 1, ngenf
C
C       Bypass if relay is tripped
C
        if (irmtcd(i) .ne. 2) then
          ibus = irmbno(i)
C
C         Check if breaker timer activated to trip
C
          if (rmbtim(i) .eq. 0.0) then
C
C           Discontinuity test
C
            if (idisw .eq. 2) then
C
C             Store voltage and bypass
C
              rmeyr(i) = eyr(ibus)
              rmeyi(i) = eyi(ibus)
              goto 110
            else
C
C             Calculate bus freq and test relay
C
              enew = eyr(ibus)
              fnew = eyi(ibus)
              efsq = enew**2 + fnew**2
              if (efsq .eq. 0.0) then
                wnew = rmfreq(i)
              else
                wnew = (fnew*rmeyr(i)-enew*rmeyi(i))/(efsq*edt)
C
C               Process frequency and voltages
C
                rmeyr(i) = enew
                rmeyi(i) = fnew
                rmfreq(i) = wnew
C
C               Check for instantaneous trip
C
                if (wnew .lt. rmfq2(i)) goto 100
              endif
C
C             Check for relay trip with delay
C
              if (wnew .ge. rmfq1(i)) then
C
C               Reset relay timer and exit
C
                rmrtim(i) = 0.0
                goto 110
              elseif (rmrtim(i) .eq. 0.0) then
C
C               Set relay timer and exit

                rmrtim(i) = rmtrp1(i) + to
                goto 110
              elseif (rmrtim(i)-0.0001 .gt. to) then
                goto 110
              endif
C
C             Check if breaker delay exists and set timer or trip
C
  100         if (rmtrp2(i) .eq. 0.0) then
C
C               No breaker time delay
C
                dnxrly = to
              else
C
C               Add breaker time delay and set next trip time--DNX
C
                rmbtim(i) = rmtrp2(i) + to
                rtemp = rmbtim(i)
                if (rtemp .lt. dnxrly) dnxrly = rtemp
                goto 110
              endif
            endif
          elseif (rmbtim(i)-.0001 .gt. to) then
            goto 110
          endif
C
C         Initiate to trip
C
          irmtcd(i) = 2
          igind = irmgno(i)
          indc = igentc(igind)
          indt(1) = igentn(1, igind)
          indt(2) = igentn(2, igind)
          ivpc = 2
          if (ibus .lt. lfrst) lfrst = ibus
          name1c = bname(ibus)
          bkv1 = buskv(ibus)
          write (outbuf, 10000) name1c, bkv1, indc, to
          call prtout(1)
10000     format ('0', 5x, 'UNDERFREQ RELAY GEN DROP AT', 5x, a8, 1x,
     &     f5.1, 1x, a1, ' AT ', f6.1, ' CYCLES')
          gndrop = 0
          call gendrp(igind, gndrop, indt(1), indt(2), indc)
        endif
  110   continue
      enddo
      return
      end


module rocblas_mm_driver_module
    use, intrinsic :: iso_fortran_env, only : &
        real32, &
        real64, &
        int64

    use, intrinsic :: iso_c_binding, only : &
            c_ptr, &
            c_int, &
            c_float, &
            c_double, &
            c_null_ptr, &
            c_associated

    use :: data_api, only : &
            stream

    use :: hip_data_plugin, only : hip_synchronize_wrapper, hip_query_stream

    use :: tensor_api, only : tensor_c_pointer_converter

    use :: matrix_multiplication_dev, only : pointer_data_mm_driver

    use :: rocblas_wrapper_module, only : &
            rocblas_create_handle, &
            rocblas_destroy_handle, &
            rocblas_set_stream, &
            rocblas_sgemm, &
            rocblas_dgemm, &
            rocblas_cgemm, &
            rocblas_zgemm, &
            rocblas_operation_none, &
            rocblas_operation_transpose, &
            rocblas_operation_conjugate_transpose, &
            rocblas_status_success

    implicit none
    private

    public :: rocblas_mm_driver

    type, extends(pointer_data_mm_driver):: rocblas_mm_driver
        type(c_ptr) :: handle = c_null_ptr
        logical :: is_initialized = .false.
    contains
        procedure :: perform_mm_r32 => perform_mm_r32
        procedure :: perform_mm_r64 => perform_mm_r64
        procedure :: perform_mm_c64 => perform_mm_c64
        procedure :: perform_mm_c128 => perform_mm_c128
        procedure :: initialize => initialize
        procedure :: cleanup => cleanup
        procedure :: synchronize => synchronize
        procedure :: clear => clear
    end type rocblas_mm_driver

    interface rocblas_mm_driver
        module procedure constructor_empty
        module procedure constructor
    end interface rocblas_mm_driver

contains
    function constructor_empty() result(this)
        type(rocblas_mm_driver) :: this

        call this%clear()
    end function constructor_empty

    function constructor(converter) result(this)
        type(tensor_c_pointer_converter), intent(in) :: converter
        type(rocblas_mm_driver) :: this

        this = rocblas_mm_driver()

        this%converter = converter
        call this%initialize()
    end function constructor

    subroutine initialize(this)
        class(rocblas_mm_driver), intent(inout) :: this

        integer(c_int) :: error

        error = rocblas_create_handle(this%handle)
        if ( error == rocblas_status_success ) then
            this%is_initialized = .true.
        else
             error stop "rocblas_mm_driver::initialize:Could not initialize."
        end if
    end subroutine initialize

    subroutine perform_mm_r32(this, dst, left, right, m, n, k, ldd, ldl, ldr, &
            alpha, beta, transposed_left, transposed_right, astream)
        class(rocblas_mm_driver), intent(in) :: this
        type(c_ptr), intent(inout) :: dst
        type(c_ptr), intent(in) :: left, right
        integer(int64), intent(in) :: m, n, k
        integer(int64), intent(in) :: ldd, ldl, ldr
        real(real32), intent(in) :: alpha, beta
        logical, intent(in) :: transposed_left, transposed_right
        type(stream), intent(in), optional :: astream

        integer(c_int) :: error, transa, transb

        if (.not. this%is_initialized ) &
                error stop "rocblas_mm_driver::perform_mm_r32:Not initialized."
        transa = rocblas_operation_none; transb = rocblas_operation_none
        if ( transposed_left) transa = rocblas_operation_transpose
        if ( transposed_right ) transb = rocblas_operation_transpose

        if ( present( astream ) ) then
            error = rocblas_set_stream(this%handle, astream%sid)
        end if

        error = rocblas_sgemm(this%handle, transa, transb, &
                int(m, c_int), int(n, c_int), int(k, c_int), &
                alpha, left, int(ldl, c_int), right, int(ldr, c_int), &
                beta, dst, int(ldd, c_int) )

        if ( error /= 0 ) &
                error stop "rocblas_mm_driver::perform_mm_r32:Error in call to rocblas_sgemm."
        error = rocblas_set_stream(this%handle, c_null_ptr)
    end subroutine perform_mm_r32

    subroutine perform_mm_r64(this, dst, left, right, m, n, k, ldd, ldl, ldr, &
            alpha, beta, transposed_left, transposed_right, astream)
        class(rocblas_mm_driver), intent(in) :: this
        type(c_ptr), intent(inout) :: dst
        type(c_ptr), intent(in) :: left, right
        integer(int64), intent(in) :: m, n, k
        integer(int64), intent(in) :: ldd, ldl, ldr
        real(real64), intent(in) :: alpha, beta
        logical, intent(in) :: transposed_left, transposed_right
        type(stream), intent(in), optional :: astream

        integer(c_int) :: error, transa, transb

        if (.not. this%is_initialized ) &
                error stop "rocblas_mm_driver::perform_mm_r64:Not initialized."
        transa = rocblas_operation_none; transb = rocblas_operation_none
        if ( transposed_left) transa = rocblas_operation_transpose
        if ( transposed_right ) transb = rocblas_operation_transpose

        if ( present( astream ) ) then
            error = rocblas_set_stream(this%handle, astream%sid)
        end if

        error = rocblas_dgemm(this%handle, transa, transb, &
                int(m, c_int), int(n, c_int), int(k, c_int), &
                alpha, left, int(ldl, c_int), right, int(ldr, c_int), &
                beta, dst, int(ldd, c_int) )

        if ( error /= 0 ) &
                error stop "rocblas_mm_driver::perform_mm_r64:Error in call to rocblas_dgemm."
        error = rocblas_set_stream(this%handle, c_null_ptr)
    end subroutine perform_mm_r64

    subroutine perform_mm_c64(this, dst, left, right, m, n, k, ldd, ldl, ldr, &
            alpha, beta, transposed_left, transposed_right, astream)
        class(rocblas_mm_driver), intent(in) :: this
        type(c_ptr), intent(inout) :: dst
        type(c_ptr), intent(in) :: left, right
        integer(int64), intent(in) :: m, n, k
        integer(int64), intent(in) :: ldd, ldl, ldr
        complex(real32), intent(in) :: alpha, beta
        logical, intent(in) :: transposed_left, transposed_right
        type(stream), intent(in), optional :: astream

        integer(c_int) :: error, transa, transb

        if (.not. this%is_initialized ) &
                error stop "rocblas_mm_driver::perform_mm_c64:Not initialized."
        transa = rocblas_operation_none; transb = rocblas_operation_none
        if ( transposed_left) transa = rocblas_operation_transpose
        if ( transposed_right ) transb = rocblas_operation_transpose

        if ( present( astream ) ) then
            error = rocblas_set_stream(this%handle, astream%sid)
        end if

        error = rocblas_cgemm(this%handle, transa, transb, &
                int(m, c_int), int(n, c_int), int(k, c_int), &
                alpha, left, int(ldl, c_int), right, int(ldr, c_int), &
                beta, dst, int(ldd, c_int) )

        if ( error /= 0 ) &
                error stop "rocblas_mm_driver::perform_mm_c64:Error in call to rocblas_dgemm."
        error = rocblas_set_stream(this%handle, c_null_ptr)
    end subroutine perform_mm_c64

    subroutine perform_mm_c128(this, dst, left, right, m, n, k, ldd, ldl, ldr, &
            alpha, beta, transposed_left, transposed_right, astream)
        class(rocblas_mm_driver), intent(in) :: this
        type(c_ptr), intent(inout) :: dst
        type(c_ptr), intent(in) :: left, right
        integer(int64), intent(in) :: m, n, k
        integer(int64), intent(in) :: ldd, ldl, ldr
        complex(real64), intent(in) :: alpha, beta
        logical, intent(in) :: transposed_left, transposed_right
        type(stream), intent(in), optional :: astream

        integer(c_int) :: error, transa, transb

        if (.not. this%is_initialized ) &
                error stop "rocblas_mm_driver::perform_mm_c128:Not initialized."
        transa = rocblas_operation_none; transb = rocblas_operation_none
        if ( transposed_left) transa = rocblas_operation_transpose
        if ( transposed_right ) transb = rocblas_operation_transpose

        if ( present( astream ) ) then
            error = rocblas_set_stream(this%handle, astream%sid)
        end if

        error = rocblas_zgemm(this%handle, transa, transb, &
                int(m, c_int), int(n, c_int), int(k, c_int), &
                alpha, left, int(ldl, c_int), right, int(ldr, c_int), &
                beta, dst, int(ldd, c_int) )

        if ( error /= 0 ) &
                error stop "rocblas_mm_driver::perform_mm_c128:Error in call to rocblas_dgemm."
        error = rocblas_set_stream(this%handle, c_null_ptr)
    end subroutine perform_mm_c128

    subroutine cleanup(this)
        class(rocblas_mm_driver), intent(inout) :: this

        integer(c_int) :: error

        call this%converter%cleanup()
        if (this%is_initialized) &
                 error = rocblas_destroy_handle(this%handle)

        call this%clear()
    end subroutine cleanup

    subroutine synchronize(this, astream)
        class(rocblas_mm_driver), intent(in) :: this
        type(stream), intent(in), optional :: astream

        integer :: error

        error = hip_synchronize_wrapper(astream)

        if (error /= 0) &
                error stop "rocblas_mm_driver::synchronize:Error in call to synchronize wrapper."
    end subroutine synchronize

    subroutine clear(this)
        class(rocblas_mm_driver), intent(inout) :: this

        this%handle = c_null_ptr
        this%is_initialized = .false.
    end subroutine clear
end module rocblas_mm_driver_module


      SUBROUTINE TEMPGR(GT,CO2ICE,IM,JM,PTROP,P,T,ASYM,TAUCRT,ALSP,FA,
     *                  EG15GND,EGOGND,SQRDY,ZIN,DT,ROT,DMADT,SDGR,
     *                  TINF,STEMP,STHICK,SCOND,DNIRFLUX,DNVFLUX,RHOUCH,
     *                  QCOND,NPCFLAG,LATHEAT,CPSOIL,RHOSOIL,QTRACE)

!     Legacy Mars GCM v24
!     Mars Climate Modeling Center
!     NASA Ames Research Center

!  PURPOSE
!      TEMPGR CALCULATES THE GROUND TEMPERATURE FOR EACH 'PI' GRID POINT
!      ON THE SURFACE OF MARS. WHERE CO2 ICE IS PRESENT ON THE GROUND,
!      THIS ALSO INVOLVES CALCULATION OF THE MASS OF CO2 ICE ON THE
!      GROUND AND SIGMA DOT AT THE GROUND.
!  INPUT PARAMETERS
!      GT(J,I) ARRAY  - GROUND TEMPERATURE OR (-1) TIMES CO2 ICE
!                             MASS AT THE 'PI' POINTS.
!      P(J,I) ARRAY   - THE CURRENT 'PI' VALUE (SURFACE PRESSURE
!                             MINUS TROPOPAUSE PRESSURE) AT THE 'PI'
!                             POINTS.
!      ALSP(J,I) ARRAY- THE LOCAL SURFACE ALBEDO FOR THE 'PI' POINTS
!                             ASSUMING NO CO2 ICE IS PRESENT.
!      T(J,I,K) ARRAY - THE TEMPERATURE AT THE MIDPOINT OF EACH
!                             LAYER FOR THE 'PI' POINTS. (K = 1 TO NLAY)
!      QDUST(J,I,K)   - THE MIXING RATIO OF DUST TO AIR IN THE KTH
!        ARRAY                LAYER. (K = 1 TO NLAY.)
!      TINF(J,I) ARRAY- THE DEEP SUBSURFACE TEMPERATURES FOR THE 'PI'
!                       POINTS.
!      DMADT(J,I)     - THE RATE OF CONDENSATION PER UNIT SURFACE AREA
!       ARRAY           IN THE WHOLE ATMOSPHERIC COLUMN AT A 'PI' GRID
!                       POINT.
!      FA(J,I) ARRAY  - THE RATE AT WHICH HEAT IS BEING GAINED BY THE
!                       SURFACE IN EXCHANGE WITH THE ATMOSPHERE
!                       (THROUGH THERMAL RADIATION AND CONVECTION)
!                       FOR EACH 'PI' POINT.
!      JBPS           - APPROXIMATE LATITUDE INDEX OF EDGE OF SOUTHERN
!                       POLAR CAP.
!      JBPN           - APPROXIMATE LATITUDE INDEX OF EDGE OF NORTHERN
!                       POLAR CAP.
!
!  OUTPUT PARAMETERS
!      GT(J,I) ARRAY  - AS IN INPUT, BUT ADJUSTED ACCORDING TO
!                       HEATING AT THE GROUND.
!      TINF(J,I) ARRAY- AS IN INPUT, BUT ADJUSTED IN PROPORTION TO
!                       TO THE NEW GROUND TEMPERATURE.
!      SDGR(J,I) ARRAY- THE VERTICAL (SIGMA) COMPONENT OF WIND VELOCITY
!                       AT THE GROUND CALCULATED FROM THE CHANGE IN THE
!                       AMOUNT OF CO2 ON THE GROUND.
!  CALLED BY
!      COMP3
!
!  SUBROUTINES CALLED
!      GETFLUX
!

      use grid_h
      use defines_h
      use constants_h, only: GRAV, STBO, XLHTC, CP
      use standard_h, only: ALICEN, ALICES, EGOCO2N, EGOCO2S, EG15CO2N,
     *                      EG15CO2S, JEQUATOR, SURFALB,ALBFEED,ICEALB,
     *                      ICETHRESH_KGM2
      use cldcommon_h

      implicit none

!######################################################################

      REAL*8  :: GT(L_JSIZE,L_ISIZE), CO2ICE(L_JSIZE,L_ISIZE)
      REAL*8  :: P(L_JSIZE,L_ISIZE)
      REAL*8  :: T(L_JSIZE,L_ISIZE,L_LAYERS)
      REAL*8  :: ALSP(L_JSIZE,L_ISIZE)
      REAL*8  :: TINF(L_JSIZE,L_ISIZE), FA(L_JSIZE,L_ISIZE)
      REAL*8  :: ZIN(L_JSIZE,L_ISIZE,NL), DMADT(L_JSIZE,L_ISIZE)
      REAL*8  :: SDGR(L_JSIZE,L_ISIZE)
      REAL*8  :: DTSDT(NL)

      REAL*8  :: RHOUCH(L_JSIZE,L_ISIZE), RHOUCHT
      REAL*8  :: DOWNIR
      real*8  :: DNIRFLUX(L_J,L_I), DNVFLUX(L_J,L_I)

      REAL*8  :: QCOND(L_JSIZE,L_ISIZE,NTRACE)
      LOGICAL :: NPCFLAG(L_JSIZE,L_ISIZE)

      REAL*4  :: LATHEAT(L_J,L_I)

!  10-07-11 latent heat updates

      real*8  :: qtrace(l_jsize,l_isize,l_layers,ntrace)
      real*8  :: h2oflux
      real*8  :: qgnd, wflux

!  FCC updates

      REAL*8  :: FLUX(2*NL+1)
      REAL*8  :: RHOSOIL(L_J,L_I,NL), CPSOIL(L_J,L_I,NL)
      REAL*8  :: STEMP(L_JSIZE,L_ISIZE,2*NL+1)
      REAL*8  :: STHICK(2*NL+1)
      REAL*8  :: SCOND(L_JSIZE,L_ISIZE,2*NL+1)

!     Implicit none

      integer :: i, j, k, l, JBCS, JBCN, IM, JM
      real*8  :: EMGOUT, TINP, SQRDY,  FCDN, TGP, DT, DMGDT, XA
      real*8  :: EMG15, EG15GND, EGOGND, X1, ASYM, TAUCRT, ROT, GTEMP
      real*8  :: PSAT, TSAT, PTROP, RGTOT, TGINF, ALS, ALCDS

!  Latent heating updates
!  Passed into TEMPGR vi cldcommon_h module

!     logical :: fullcomp3
!     real*8  :: subflux(L_JSIZE,L_ISIZE)
!     real*8  :: gndice(L_JSIZE,L_ISIZE)

!#=====================================================================

!  First time in tempgr after a full trip through comp3?

      if(FULLCOMP3) then
        FULLCOMP3 = .FALSE.
        do J=1,JM-1
          do I=1,IM
            subflux(j,i) = 0.0D0
            gndice(J,I)  = QCOND(J,I,iMa_vap)
          end do
        end do
      end if

!     GROUND TEMPERATURE CALCULATION DONE EVERY TIME STEP

      DO 4150 I=1,IM
         DO 4151 J=1,JM-1

            DMGDT     = 0.0D0
            SDGR(J,I) = 0.0D0

!           FIRST CALCULATE 'SURFACE' ALBEDO.

            ALS = ALSP(J,I)

!           Check for CO2 ice on the ground.

            IF(CO2ICE(J,I) .gt. 0.0) THEN

              IF(J.LT.JEQUATOR) THEN
                ALS = ALICES
              ELSE
                ALS = ALICEN
              END IF
            ELSEIF (ALBFEED .and. QCOND(J,I,iMa_vap).gt.
     *              icethresh_kgm2
     *              .and. (NPCFLAG(J,I) .eqv. .FALSE.)) THEN
                 ALS = icealb
            END IF

            surfalb(J,I) = ALS

!           TINF is the deep subsurface temperature, FA the heat
!           exchange from convection and thermal radiation from
!           the atmosphere.

            RGTOT = FA(J,I)

!           Get TSAT, the CO2 frost point at this surface pressure.

            PSAT = P(J,I)+PTROP
            TSAT = 3182.48D0/(23.3494D0-LOG(PSAT))

!  Begin major modifications

            IF(CO2ICE(J,I).le.0.0) THEN  ! no CO2 on the ground

              CO2ICE(J,I) = 0.0D0

!             Emissivities for bare ground

              EMG15  = EG15GND
              EMGOUT = EGOGND

!             CHANGE TG FOR HEATING & COOLING EFFECTS.

!             New soil scheme: surface boundary condition
!             Changes to the new ground temperature computation

              DOWNIR  = EMG15*DNIRFLUX(J,I)
              RHOUCHT = RHOUCH(J,I)*T(J,I,L_LAYERS)

!             Newton-Raphson method of solving for Tg, with new
!             Tg-dependent terms (RHOUCH, RHOUCHT replace RGTOT) added
!             to the mix

              CALL NEWTG(ALS,DNVFLUX(J,I),DOWNIR,RHOUCH(J,I),RHOUCHT,
     *                   SCOND(J,I,2),STEMP(J,I,2),STHICK(2),
     *                   GT(J,I),J,I,PSAT,QTRACE(J,I,L_LAYERS,iMa_vap),
     *                   gndice(J,I),dt,subflux(j,i),npcflag(j,i))

              IF(GT(J,I).lt.TSAT) THEN

                GT(J,I) = TSAT

!               Emissivities of bare ground since CO2 ice just starting

                EMG15  = EG15GND
                EMGOUT = EGOGND

                FCDN = -2.0D0*SCOND(J,I,2)*(STEMP(J,I,2)-TSAT)/
     *                        STHICK(2)

                TGP  = DT*((1.0D0-ALS)*DNVFLUX(J,I)+RGTOT-
     *                 EMG15*(STBO*TSAT**4) - FCDN)/XLHTC

!               Check to see if there is any CO2 ice accumulation.

                IF(TGP.LT.0.0) THEN

                  DMGDT       = -TGP/DT
                  CO2ICE(J,I) = -TGP

                ELSE

                  DMGDT     = 0.0D0

!                 This term represents the last amounts of ice
!                 evaporating resulting in an increase in Tg. It still
!                 depends on TINP until I can figure out what to do
!                 with it.

!                 added 5/13/04,modified 5/13/08
                  TINP        = SQRDY/zin(j,i,1)
                  GT(J,I)     = TSAT+(TGP*XLHTC*TINP)
                  CO2ICE(J,I) = 0.0D0

                ENDIF

              ENDIF

            ELSE    ! CO2 ice on the ground

              GT(J,I) = TSAT

!  Only modify if we have water condensation
!  Latent heating update Oct. 2011

              wflux = 0.0

              qgnd  = (18.0/44.0)*
     *                6.11*exp(22.5*(1.0-(273.16/GT(j,i))))/psat
              wflux = -rhouch(j,i)*
     *                 (QTRACE(J,I,L_LAYERS,iMa_vap)-qgnd)/cp
              if(wflux.lt.0.0) then
                gndice(j,i) = gndice(j,i) - wflux*dt

!  Note:  wflux > 0 is sublimation
!         wflux < 0 is condensation

                SUBFLUX(J,I) = SUBFLUX(J,I) + wflux*dt
              end if

!             Emissivities of CO2 ice on the ground.

              IF(J.LT.JEQUATOR) THEN
                EMG15  = EG15CO2S
                EMGOUT = EGOCO2S
               ELSE
                EMG15  = EG15CO2N
                EMGOUT = EGOCO2N
              END IF

!             New soil scheme: surface boundary condition with ice on
!             ground

              FCDN = -2.0D0*SCOND(J,I,2)*(STEMP(J,I,2)-TSAT)/
     *                      STHICK(2)

              TGP  = -CO2ICE(J,I) + DT*((1.0D0-ALS)*DNVFLUX(J,I)+RGTOT-
     *                EMG15*(STBO*TSAT**4) - FCDN)/XLHTC

!             Check to see if there is any CO2 ice still left.

              IF(TGP.LT.0.0) THEN

                DMGDT       = -(CO2ICE(J,I)+TGP)/DT
                CO2ICE(J,I) = -TGP

              ELSE

                DMGDT = -CO2ICE(J,I)/DT

!               This term represents the last amounts of ice evaporating
!               resulting in an increase in Tg. It still depends on TINP
!               until I can figure out what to do with it.

                TINP        = SQRDY/zin(j,i,1)
                GT(J,I)     = TSAT+(TGP*XLHTC*TINP)
                CO2ICE(J,I) = 0.0D0

              ENDIF

            ENDIF

!  End major modification

            X1 = GT(J,I)
!
! Begin new soil scheme
!

!  Calculate fluxes at layer boundaries
!  Fluxes defined as positive downward

           do K=3,2*NL-1,2
             flux(K) = -scond(J,I,k)*(stemp(J,I,K+1) - stemp(J,I,K-1))/
     *                  sthick(K)
           end do

!  Calculate flux at top and bottom

           flux(1)      = -2.0D0*scond(J,I,2)*(stemp(J,I,2) - X1)/
     *                         sthick(2)
           flux(2*NL+1) = 0.0

!  Update soil temperatures

           do L=1,NL
             K = 2*L
             stemp(J,I,K) = stemp(J,I,K) - dt*(flux(k+1) - flux(K-1))/
     *                      (rhosoil(J,I,L)*cpsoil(J,I,L)*sthick(K))
           end do

!
! End new soil scheme

      SDGR(J,I) = GRAV * (DMGDT + DMADT(J,I))

 4151 CONTINUE
 4150 CONTINUE

      RETURN
      END


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine stageo ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Geometric mean of a variable during a certian time span

!
!     Description of the module :
!
!        General water quality module for DELWAQ:
!
!        Calculates the geometric mean of a series of values. To take
!        care of the problem of very small values (that would distort
!        the calculated mean), a threshold is set.
!
!
! Name    T   L I/O   Description                                  Units
! ----    --- -  -    -------------------                          -----
!
! CONC           I    Concentration of the substance              1
! TSTART         I    Start of statistical period                 2
! TSTOP          I    Stop of statistical period                  3
! TIME           I    Time in calculation                         4
! DELT           I    Timestep                                    5
! THRESH         I    Threshold for considering the value         6
!
! TCOUNT         O    Count of timesteps                          7
! TCNTAB         O    Count of timesteps with values above        8
! GEOMN          O    Geometric mean, values above threshold      9
! GEOALL         O    Geometric mean, all values                 10
!

!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------

      IMPLICIT NONE

      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4
!
      INTEGER  IP1   , IP2   , IP3   , IP4   , IP5   ,
     +         IP6   , IP7   , IP8   , IP9   , IP10  ,
     +         IN1   , IN2   , IN3   , IN4   , IN5   ,
     +         IN6   , IN7   , IN8   , IN9   , IN10
      INTEGER  IKMRK , IKMRK1, IKMRK2, ISEG  , IQ    , IFROM , ITO
      INTEGER  LUNREP, ITYPE
      REAL     TSTART, TSTOP , TIME  , DELT
      REAL     THRESH, TCOUNT, TCNTAB, THRLOG, PMLOG

      IP1 = IPOINT(1)
      IP2 = IPOINT(2)
      IP3 = IPOINT(3)
      IP4 = IPOINT(4)
      IP5 = IPOINT(5)
      IP6 = IPOINT(6)
      IP7 = IPOINT(7)
      IP8 = IPOINT(8)
      IP9 = IPOINT(9)
      IP10= IPOINT(10)

      IN1 = INCREM(1)
      IN2 = INCREM(2)
      IN3 = INCREM(3)
      IN4 = INCREM(4)
      IN5 = INCREM(5)
      IN6 = INCREM(6)
      IN7 = INCREM(7)
      IN8 = INCREM(8)
      IN9 = INCREM(9)
      IN10= INCREM(10)

!
!     There are five cases, defined by the time:
!                        TIME <  TSTART-0.5*DELT : do nothing
!     TSTART-0.5*DELT <= TIME <  TSTART+0.5*DELT : initialise
!     TSTART          <  TIME <  TSTOP           : accumulate
!     TSTOP           <= TIME <  TSTOP+0.5*DELT  : finalise
!     TSTOP+0.5*DELT  <  TIME                    : do nothing
!
!     (Use a safe margin)
!
      TSTART = PMSA(IP2)
      TSTOP  = PMSA(IP3)
      TIME   = PMSA(IP4)
      DELT   = PMSA(IP5)
      THRESH = PMSA(IP6)

      IF ( THRESH .LE. 0.0 ) THEN
         CALL GETMLU( LUNREP )
         WRITE( LUNREP, * ) 'ERROR in STAGEO'
         WRITE( LUNREP, * )
     &'Threshold must be a positive value'
         WRITE( LUNREP, * )
     &'Threshold: ', THRESH
         WRITE( *     , * ) 'ERROR in STAGEO'
         WRITE( *     , * )
     &'Threshold must be a positive value'
         WRITE( LUNREP, * )
     &'Threshold: ', THRESH
         CALL SRSTOP( 1 )
      ENDIF

      THRLOG = LOG(THRESH) * DELT

      TCOUNT = PMSA(IP7)

!
!      Start and stop criteria are somewhat involved. Be careful
!      to avoid spurious calculations (initial and final) when
!      none is expected.
!      Notes:
!      - The initial value for TCOUNT must be 0.0
!      - Time is expected to be the model time (same time frame
!        as the start and stop times of course)
!      - Check that the NEXT timestep will not exceed the stop time,
!        otherwise this is the last one
!
      ITYPE  = 0
      IF ( TIME .GE. TSTART-0.001*DELT ) THEN
         ITYPE = 2
         IF ( TCOUNT .EQ. 0.0 ) ITYPE = 1
      ENDIF
      IF ( TIME .GE. TSTOP-0.999*DELT ) THEN
         ITYPE  = 3
         IF ( TCOUNT .LE. 0.0 ) ITYPE = 0
      ENDIF

      IF ( ITYPE  .EQ. 0 ) RETURN

      TCOUNT    = TCOUNT + DELT
      PMSA(IP7) = TCOUNT

      DO 9000 ISEG=1,NOSEG
         IF (BTEST(IKNMRK(ISEG),0)) THEN

!
!        The first time is special. Initialise the arrays.
!        The last time requires additional processing.
!
         IF ( ITYPE .EQ. 1 ) THEN
            PMSA(IP8) = 0.0
            PMSA(IP9) = 0.0
            PMSA(IP10)= 0.0
         ENDIF

         IF ( PMSA(IP1) .GE. THRESH ) THEN
            PMLOG      = LOG(PMSA(IP1)) * DELT
            PMSA(IP8)  = PMSA(IP8) + DELT
            PMSA(IP9)  = PMSA(IP9) + PMLOG
            PMSA(IP10) = PMSA(IP10)+ PMLOG
         ELSE
            PMSA(IP10) = PMSA(IP10)+ THRLOG
         ENDIF

         IF ( ITYPE .EQ. 3 ) THEN
            IF ( TCOUNT .GT. 0.0 ) THEN
               IF ( PMSA(IP8) .GT. 0.0 ) THEN
                  PMSA(IP9) = EXP( PMSA(IP9) / PMSA(IP8) )
               ELSE
                  PMSA(IP9) = 0.0
               ENDIF
               PMSA(IP10)= EXP( PMSA(IP10)/ TCOUNT )
            ELSE
               PMSA(IP9) = 0.0
               PMSA(IP10)= 0.0
            ENDIF
         ENDIF

         ENDIF

         IP1  = IP1  + IN1
         IP8  = IP8  + IN8
         IP9  = IP9  + IN9
         IP10 = IP10 + IN10

 9000 CONTINUE

!
!     Be sure to turn off the statistical procedure, once the end has been
!     reached (by setting TCOUNT (PMSA(IP7)) to a non-positive value)
!
      IF ( ITYPE .EQ. 3 ) THEN
         PMSA(IP7) = -TCOUNT
      ENDIF

      RETURN
      END


MODULE CAMSPEC_EXTRA

    IMPLICIT NONE

    INTEGER:: BOK = 0
    real(8), dimension(:), allocatable :: cltt,nuisance
    INTEGER::lmin,lmax
    INTEGER::xcase,npar
END MODULE CAMSPEC_EXTRA

SUBROUTINE CAMSPEC_EXTRA_ONLY_ONE(MOK)
    USE CAMSPEC_EXTRA
    INTEGER,INTENT(OUT)::MOK
    MOK = BOK
    BOK = 1
END SUBROUTINE  CAMSPEC_EXTRA_ONLY_ONE

SUBROUTINE CAMSPEC_EXTRA_FREE()
    USE CAMSPEC_EXTRA
    DEALLOCATE(cltt)
    BOK =0
END SUBROUTINE  CAMSPEC_EXTRA_FREE

SUBROUTINE CAMSPEC_EXTRA_INIT(iNspec, inX,ilminX,ilmaxX,inp,inpt, ic_inv,iX,ilmax_sz,isz_143_temp,iksz_temp,itszxcib_temp,ibeam_Nspec,inum_modes_per_beam,ibeam_lmax,icov_dim,ibeam_cov_inv,ibeam_modes,ihas_dust,ihas_calib,imarge_flag, imarge_mode,imarge_num, ikeep_num,bs_factor)
    USE CAMSPEC_EXTRA
    USE temp_like
    implicit none
    integer,intent(in)::iNspec,inX,inum_modes_per_beam,ibeam_lmax,ibeam_Nspec,icov_dim,ilmax_sz,ihas_dust,ihas_calib
    integer,dimension(1:iNspec)::ilminX,ilmaxX,inp,inpt
    real*8, dimension(1:iNx) :: iX
    real*8,  dimension(1:iNx,1:iNx) ::ic_inv
    real*8,intent(in) :: iksz_temp(0:ilmax_sz), itszxcib_temp(0:ilmax_sz)
    real*8,intent(in) :: isz_143_temp(0:ilmax_sz)
    real*8, dimension(1:icov_dim,1:icov_dim) :: ibeam_cov_inv
    real*8, dimension(1:inum_modes_per_beam,0:ibeam_lmax,1:ibeam_Nspec) :: ibeam_modes ! mode#, l, spec#
    integer, dimension(1:icov_dim)::imarge_flag
    logical,dimension(1:icov_dim)::marge_flag
    integer::imarge_num,ikeep_num
    real*8,dimension(1:imarge_num, 1:ikeep_num)::imarge_mode
    real*8::bs_factor

    integer::i

    do i=1,icov_dim
        marge_flag(i) = (imarge_flag(i).eq.1)
    enddo

    call like_init_frommem(iNspec, inX,ilminX,ilmaxX,inp,inpt, ic_inv,iX,ilmax_sz,isz_143_temp,iksz_temp,itszxcib_temp,ibeam_Nspec,inum_modes_per_beam,ibeam_lmax,icov_dim,ibeam_cov_inv,ibeam_modes,ihas_dust,ihas_calib,marge_flag,imarge_mode)

    lmax = ilmaxX(1)
    DO i=2,iNspec
        IF (lmax<ilmaxX(i)) lmax = ilmaxX(i)
    ENDDO
    lmin = ilminX(1)
    DO i=2,iNspec
        IF (lmin>ilminX(i)) lmin = ilminX(i)
    ENDDO

    xcase = 1
    !IF (mlmax2.ne.0) xcase = 1

    ALLOCATE(cltt(0:lmax+1))

    allocate(nuisance(num_non_beam+ihas_dust+beam_Nspec*num_modes_per_beam - marge_num))
    npar = lmax+1-lmin+num_non_beam+ beam_Nspec * num_modes_per_beam +ihas_dust - marge_num
    beam_factor = bs_factor

END SUBROUTINE CAMSPEC_EXTRA_INIT

SUBROUTINE CAMSPEC_EXTRA_GETCASE(xc)
    USE CAMSPEC_EXTRA
    INTEGER::xc

    xc = xcase
END SUBROUTINE CAMSPEC_EXTRA_GETCASE

SUBROUTINE CAMSPEC_EXTRA_LKL(LKL,CL)
    USE CAMSPEC_EXTRA
    use temp_like
    implicit none

    REAL(8),INTENT(OUT)::LKL
    REAL(8),DIMENSION(0:npar-1)::CL
    real(8)::zlike, A_ps_100, A_ps_143, A_ps_217, A_cib_143, A_cib_217, A_sz, r_ps, r_cib, &
         cal0, cal1, cal2, xi, A_ksz
    real*8, dimension(1:beam_Nspec,1:num_modes_per_beam) :: beam_coeffs
    INTEGER::l,i,j,cnt
    real(8)::tlkl

    cltt(:lmin-1) = 0
    DO l=lmin,lmax
        ! camspec expects cl/2pi !!! argl !
        !cltt(l)=CL(l-lmin)/2./3.14159265358979323846264338328
        cltt(l)=CL(l-lmin)/2./3.141592653589793
    ENDDO

    do i=1,num_non_beam
        nuisance(i) = CL(lmax+1-lmin + i-1)
    enddo
    !A_ps_100  = CL(lmax+1-lmin + 0)
    !A_ps_143  = CL(lmax+1-lmin + 1)
    !A_ps_217  = CL(lmax+1-lmin + 2)
    !A_cib_143 = CL(lmax+1-lmin + 3)
    !A_cib_217 = CL(lmax+1-lmin + 4)
    !A_sz      = CL(lmax+1-lmin + 5)
    !r_ps      = CL(lmax+1-lmin + 6)
    !r_cib     = CL(lmax+1-lmin + 7)
    !cal0      = CL(lmax+1-lmin + 8)
    !cal1      = CL(lmax+1-lmin + 9)
    !cal2      = CL(lmax+1-lmin + 10)
    !xi        = CL(lmax+1-lmin + 11)
    !A_ksz     = CL(lmax+1-lmin + 12)

    !print *,CL(lmax+1-lmin+14)

    cnt = 1
    DO i=1,keep_num
            nuisance(cnt+num_non_beam) = CL(lmax+1-lmin+num_non_beam+cnt-1)
            cnt = cnt + 1
    ENDDO

    call calc_like(tlkl,  cltt,nuisance)
    ! lkl is -2loglike clik returns loglik
    !print *,tlkl
    lkl = -tlkl/2.

END SUBROUTINE CAMSPEC_EXTRA_LKL

SUBROUTINE CAMSPEC_EXTRA_FG(rCL_FG,NUIS,lm)
    USE CAMSPEC_EXTRA
    use temp_like
    implicit none
    REAL(8),DIMENSION(1:num_non_beam+beam_Nspec*num_modes_per_beam)::NUIS
    REAL(8),dimension(4,0:lm)::rCL_FG
    integer::lm

    call COMPUTE_FG(rCL_FG,NUIS)

END SUBROUTINE


*----------------------------------------------------------------------*
      subroutine contr_blk1blk2_blocked_mm(xfac,         !prefactor
     &     xop1op2,xop1,xop2,                     !buffers: res,op1,op2
     &     tra_op1,tra_op2,tra_op1op2,
     &     xscr,lenscr,lenblock,lenblock_cnt,               ! scratch
     &     ncblk_op1,nablk_op1,ncblk_ex1,nablk_ex1,
     &     ncblk_op2,nablk_op2,ncblk_ex2,nablk_ex2,
     &     ncblk_cnt,nablk_cnt,ncblk_op1op2,nablk_op1op2,
     &     hpvxop1c, hpvxop1a,
     &     hpvxop2c, hpvxop2a,
     &     hpvxop1op2c, hpvxop1op2a,
     &     lstrop1, lstrop2, lstrop1op2,
     &     lstr_ex1, lstr_ex2, lstr_cnt,
     &     map_info_12c, map_info_12a,
     &     map_info_1c, map_info_1a,
     &     map_info_2c, map_info_2a,
     &     map_ex1ex2c, map_ex1ex2a,
     &     map_ex1cntc, map_ex1cnta,
     &     map_ex2cntc, map_ex2cnta
     &     )
*----------------------------------------------------------------------*
*     inner contraction routine, generation 3
*     - blocked reordering
*     - blocked dgemm
*----------------------------------------------------------------------*

      implicit none

      include 'contr_times.h'

      include 'opdim.h'
      include 'stdunit.h'
      include 'def_orbinf.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'hpvxseq.h'

      integer, parameter ::
     &     ntest =  000

c      integer, parameter ::
c     &     lenblock = 1000
c     &     lenblock = 200

      ! lstrop1op2a(ncblk_op1op2a): # of strings
      ! etc.
      ! iocc_op1op2: occupation
      ! nstr_ex1/ex2/cnt,a/c: # strings
      ! map_ex1ex2a/c  mapping ex1*ex2->op1op2
      ! etc. for ex1cnt ex2cnt
      logical, intent(in) ::
     &     tra_op1, tra_op2, tra_op1op2
      integer, intent(in) ::
     &     lenblock,lenblock_cnt,
     &     ncblk_op1,nablk_op1,ncblk_ex1,nablk_ex1,
     &     ncblk_op2,nablk_op2,ncblk_ex2,nablk_ex2,
     &     ncblk_cnt,nablk_cnt,ncblk_op1op2,nablk_op1op2,
     &     lstrop1(*), lstrop2(*), lstrop1op2(*),
     &     hpvxop1a(*), hpvxop2a(*), hpvxop1op2a(*),
     &     hpvxop1c(*), hpvxop2c(*), hpvxop1op2c(*),
     &     lstr_ex1(*), lstr_ex2(*), lstr_cnt(*),
     &     map_info_12c(*), map_info_12a(*),
     &     map_info_1c(*), map_info_1a(*),
     &     map_info_2c(*), map_info_2a(*),
     &     map_ex1ex2a(*), map_ex1ex2c(*),
     &     map_ex1cnta(*), map_ex1cntc(*),
     &     map_ex2cnta(*), map_ex2cntc(*),
     &     lenscr
      real(8), intent(in) ::
     &     xop1(*), xop2(*), xfac
      real(8), intent(inout) ::
     &     xop1op2(*),
     &     xscr(*)

      logical ::
     &     op1shorter
      integer ::
     &     ireo_ex1a1(nablk_ex1),   ireo_ex1c1(ncblk_ex1),
     &     ireo_ex1a12(nablk_ex1),  ireo_ex1c12(ncblk_ex1),
     &     ireo_ex2a2(nablk_ex2),   ireo_ex2c2(ncblk_ex2),
     &     ireo_ex2a12(nablk_ex2),  ireo_ex2c12(ncblk_ex2),
     &     ireo_cnta1(nablk_cnt),   ireo_cntc1(ncblk_cnt),
     &     ireo_cnta2(nablk_cnt),   ireo_cntc2(ncblk_cnt)
      integer ::
     &     nstr_ex1a1(nablk_op1),   nstr_ex1c1(ncblk_op1),
     &     nstr_ex1a12(nablk_op1op2),  nstr_ex1c12(ncblk_op1op2),
     &     nstr_ex2a2(nablk_op2),   nstr_ex2c2(ncblk_op2),
     &     nstr_ex2a12(nablk_op1op2),  nstr_ex2c12(ncblk_op1op2),
     &     nstr_cnta1(nablk_op1),   nstr_cntc1(ncblk_op1),
     &     nstr_cnta2(ncblk_op2),   nstr_cntc2(nablk_op2),
     &     nstr_ex1ex2a(nablk_op1op2), nstr_ex1ex2c(ncblk_op1op2),
     &     nstr_ex1cnta(nablk_op1), nstr_ex1cntc(ncblk_op1),
     &     nstr_ex2cnta(nablk_op2), nstr_ex2cntc(ncblk_op2),
     &     ldim_op1a(nablk_op1), ldim_op1c(ncblk_op1),
     &     ldim_op2a(nablk_op2), ldim_op2c(ncblk_op2),
     &     ldim_op1op2a(nablk_op1op2), ldim_op1op2c(ncblk_op1op2),
     &     istrscr1_c(ncblk_op1op2), istrscr1_a(nablk_op1op2),
     &     istrscr2_c(ncblk_op1op2), istrscr2_a(nablk_op1op2)
      integer ::
     &     lscr_op1op2, idxopsscr, idxoplscr, idxop1op2scr, idx, idxend,
     &     nstr_ex1a_tot, nstr_ex1c_tot,
     &     nstr_ex2a_tot, nstr_ex2c_tot,
     &     nstr_exsa_tot, nstr_exsc_tot,
     &     nstr_exla_tot, nstr_exlc_tot,
     &     nstr_cnta_tot, nstr_cntc_tot,
     &     lenop1, lenop2, lenop12,
     &     maxlen_cnt_batch, maxlen_exl_batch, maxlen_exs_batch,
     &     n_cnt_batch, n_exl_batch, n_exs_batch,
     &     cnt_batch, exl_batch, exs_batch, ncnt, nexl, nexs,
     &     istr_cntc_bst, istr_cntc_bnd, istr_cnta_bst, istr_cnta_bnd,
     &     istr_exsc_bst, istr_exsc_bnd, istr_exsa_bst, istr_exsa_bnd,
     &     istr_exlc_bst, istr_exlc_bnd, istr_exla_bst, istr_exla_bnd

      real(8) ::
     &     cpu, sys, cpu0, sys0
c dbg
c     &     , cpu00, sys00, cpu1, sys1, cpu2, sys2, cpu3, sys3, cpu4,sys4
c dbg
      integer, external ::
     &     ielprd
c dbg
c      call atim_cs(cpu00,sys00)
c dbg

      lenop1  = ielprd(lstrop1,ncblk_op1+nablk_op1)
      lenop2  = ielprd(lstrop2,ncblk_op2+nablk_op2)
      lenop12 = ielprd(lstrop1op2,ncblk_op1op2+nablk_op1op2)

      nstr_ex1c_tot = ielprd(lstr_ex1,ncblk_ex1)
      nstr_ex1a_tot = ielprd(lstr_ex1(ncblk_ex1+1),nablk_ex1)
      nstr_ex2c_tot = ielprd(lstr_ex2,ncblk_ex2)
      nstr_ex2a_tot = ielprd(lstr_ex2(ncblk_ex2+1),nablk_ex2)
      nstr_cntc_tot = ielprd(lstr_cnt,ncblk_cnt)
      nstr_cnta_tot = ielprd(lstr_cnt(ncblk_cnt+1),nablk_cnt)

      ! C: ex1,ex2
      call set_strmapdim_c2(nstr_ex1ex2c,nstr_ex1c12,nstr_ex2c12,
     &                   ireo_ex1c12,ireo_ex2c12,
     &                   ncblk_op1op2,
     &                   lstr_ex1,lstr_ex2,map_info_12c)
      ! A: ex2,ex1
      call set_strmapdim_c2(nstr_ex1ex2a,nstr_ex2a12,nstr_ex1a12,
     &                   ireo_ex2a12,ireo_ex1a12,
     &                   nablk_op1op2,
     &                   lstr_ex2(ncblk_ex2+1),
     &                    lstr_ex1(ncblk_ex1+1),map_info_12a)
      call set_strmapdim_c2(nstr_ex1cntc,nstr_cntc1,nstr_ex1c1,
     &                   ireo_cntc1,ireo_ex1c1,
     &                   ncblk_op1,
     &                   lstr_cnt,lstr_ex1,map_info_1c)
      call set_strmapdim_c2(nstr_ex1cnta,nstr_cnta1,nstr_ex1a1,
     &                   ireo_cnta1,ireo_ex1a1,
     &                   nablk_op1,
     &                   lstr_cnt(ncblk_cnt+1),
     &                     lstr_ex1(ncblk_ex1+1),map_info_1a)
      call set_strmapdim_c2(nstr_ex2cntc,nstr_cnta2,nstr_ex2c2,
     &                   ireo_cnta2,ireo_ex2c2,
     &                   ncblk_op2,
     &                   lstr_cnt(ncblk_cnt+1),lstr_ex2,map_info_2c)
      call set_strmapdim_c2(nstr_ex2cnta,nstr_cntc2,nstr_ex2a2,
     &                   ireo_cntc2,ireo_ex2a2,
     &                   nablk_op2,
     &                   lstr_cnt,lstr_ex2(ncblk_ex2+1),map_info_2a)

      call set_op_ldim_c(ldim_op1c,ldim_op1a,
     &                   hpvxop1c,hpvxop1a,
     &                   lstrop1,ncblk_op1,nablk_op1,tra_op1)
      call set_op_ldim_c(ldim_op2c,ldim_op2a,
     &                   hpvxop2c,hpvxop2a,
     &                   lstrop2,ncblk_op2,nablk_op2,tra_op2)
      call set_op_ldim_c(ldim_op1op2c,ldim_op1op2a,
     &                   hpvxop1op2c,hpvxop1op2a,
     &                   lstrop1op2,ncblk_op1op2,nablk_op1op2,
     &                                               tra_op1op2)
      if (ntest.ge.100) then
        call write_title(lulog,wst_dbg_subr,
     &       'News from contr_op1op2_blocked_mm')
      end if

      ! divide scratch into three blocks
      ! block for raw op1op2 batch needs at most lenblock^2
      ! (or #Ex1*#Ex2, if that is less)
      lscr_op1op2 = min(nstr_ex1c_tot*nstr_ex1a_tot*
     &                  nstr_ex2c_tot*nstr_ex2a_tot,lenblock*lenblock)
      ! blocks for resorted ops:
      ! is Op1 or Op2 list shorter? OpSHORT, OpLONG
      ! determine length of CNT blocks
      ! such that OpSH(CNT,EX) fits into scratch for all EX
      op1shorter = nstr_ex1c_tot*nstr_ex1a_tot.le.
     &             nstr_ex2c_tot*nstr_ex2a_tot
      if (op1shorter) then
        maxlen_exl_batch = min(nstr_ex2c_tot*nstr_ex2a_tot,lenblock)
        maxlen_exs_batch = min(nstr_ex1c_tot*nstr_ex1a_tot,lenblock)
        maxlen_cnt_batch = min(nstr_cntc_tot*nstr_cnta_tot,
     &       (lenscr-lscr_op1op2-1)/
     &       (    nstr_ex1c_tot*nstr_ex1a_tot + maxlen_exl_batch)+1)
        nstr_exsc_tot = nstr_ex1c_tot
        nstr_exsa_tot = nstr_ex1a_tot
        nstr_exlc_tot = nstr_ex2c_tot
        nstr_exla_tot = nstr_ex2a_tot
      else
        maxlen_exl_batch = min(nstr_ex1c_tot*nstr_ex1a_tot,lenblock)
        maxlen_exs_batch = min(nstr_ex2c_tot*nstr_ex2a_tot,lenblock)
        maxlen_cnt_batch = min(nstr_cntc_tot*nstr_cnta_tot,
     &       (lenscr-lscr_op1op2-1)/
     &       (    nstr_ex2c_tot*nstr_ex2a_tot + maxlen_exl_batch)+1)
        nstr_exsc_tot = nstr_ex2c_tot
        nstr_exsa_tot = nstr_ex2a_tot
        nstr_exlc_tot = nstr_ex1c_tot
        nstr_exla_tot = nstr_ex1a_tot
      end if

      ! restrict CNT batch length, if requested
      if (lenblock_cnt.gt.0)
     &     maxlen_cnt_batch = min(maxlen_cnt_batch,lenblock_cnt)

      if (maxlen_cnt_batch.lt.1)
     &     call quit(1,'contr_blk1blk2_blocked_mm',
     &     'insufficient scratch memory')

      idxopsscr = 1
      idxoplscr = idxopsscr +
     &     nstr_exsc_tot*nstr_exsa_tot*maxlen_cnt_batch
      idxop1op2scr = idxoplscr +
     &     maxlen_cnt_batch*maxlen_exl_batch
      idxend    = idxop1op2scr + maxlen_exl_batch*maxlen_exs_batch

      cnt_maxscr = max(cnt_maxscr,idxend)

      if (idxend.gt.lenscr)
     &     call quit(1,'contr_blk1blk2_blocked_mm',
     &                 'error in setting up batch lengthes')

      n_cnt_batch = (nstr_cntc_tot*nstr_cnta_tot-1)/maxlen_cnt_batch + 1

      n_exl_batch = (nstr_exlc_tot*nstr_exla_tot-1)/maxlen_exl_batch + 1

      n_exs_batch = (nstr_exsc_tot*nstr_exsa_tot-1)/maxlen_exs_batch + 1

      if (ntest.ge.100) then
        write(lulog,*) 'batching info: '
        write(lulog,*) 'lenop: ',lenop1,lenop2,lenop12
        write(lulog,*) 'op1shorter: ',op1shorter
        write(lulog,*) '# CNT    : ',nstr_cntc_tot*nstr_cnta_tot
        write(lulog,*) '# EXlong : ',nstr_exlc_tot*nstr_exla_tot
        write(lulog,*) '# EXshort: ',nstr_exsc_tot*nstr_exsa_tot
        write(lulog,*) 'n_cnt_batch = ',n_cnt_batch
        write(lulog,*) 'n_exl_batch = ',n_exl_batch
        write(lulog,*) 'n_exs_batch = ',n_exs_batch
        write(lulog,*) 'maxlen_cnt_batch = ',maxlen_cnt_batch
        write(lulog,*) 'maxlen_exl_batch = ',maxlen_exl_batch
        write(lulog,*) 'maxlen_exs_batch = ',maxlen_exs_batch
        write(lulog,*) 'lenscr = ',lenscr
        write(lulog,*) 'idxscr = ',idxopsscr, idxoplscr, idxop1op2scr
      end if
c dbg
c      call atim_cs(cpu,sys)
c     cnt_test(3) = cnt_test(3)+cpu-cpu00
c     cnt_test(4) = cnt_test(4)+sys-sys00
c dbg

c dbg
c     call atim_cs(cpu1,sys1)
c dbg
      ! loop over CNT blocks
      do cnt_batch = 1, n_cnt_batch

        call idxstnd_batch(ncnt,
     &       istr_cntc_bst,istr_cnta_bst,
     &       istr_cntc_bnd,istr_cnta_bnd,
     &       cnt_batch,nstr_cntc_tot,nstr_cnta_tot,
     &       maxlen_cnt_batch)

        if (ntest.ge.1000) then
          write(lulog,*) 'cnt-batch: ',cnt_batch
          write(lulog,*) 'maxlen_cnt_batch: ',maxlen_cnt_batch
          write(lulog,*) 'ncnt = ',ncnt
          write(lulog,*) ' CNT(C) from ',istr_cntc_bst,
     &                            ' to ',istr_cntc_bnd
          write(lulog,*) ' CNT(A) from ',istr_cnta_bst,
     &                            ' to ',istr_cnta_bnd
        end if

c        call atim_cs(cpu0,sys0)

        ! resort OpSHORT
        if (op1shorter) then
          ! OMP: make loop over L-string (EX1)
          !call collect_block(xscr(idxopsscr),xop1,
          call collect_block_impr(xscr(idxopsscr),xop1,
          !call collect_block_n(xscr(idxopsscr),xop1,
     &         istr_cntc_bst,istr_cntc_bnd,nstr_cntc_tot,
     &         istr_cnta_bst,istr_cnta_bnd,nstr_cnta_tot,
     &         ncnt,.false.,
     &         1            ,nstr_ex1c_tot,nstr_ex1c_tot,
     &         1            ,nstr_ex1a_tot,nstr_ex1a_tot,
     &         nstr_ex1c_tot*nstr_ex1a_tot,
     &         map_ex1cntc,map_ex1cnta,
     &         ncblk_op1,nablk_op1,
     &         ldim_op1c,ldim_op1a,
     &         ncblk_cnt,nablk_cnt,
     &         ncblk_ex1,nablk_ex1,
     &         lstr_cnt,lstr_cnt(ncblk_cnt+1),
     &         lstr_ex1,lstr_ex1(ncblk_ex1+1),
     &         nstr_cntc1,nstr_cnta1,
     &         nstr_ex1c1,nstr_ex1a1,
     &         ireo_cntc1,ireo_cnta1,
     &         ireo_ex1c1,ireo_ex1a1)
        else
          ! OMP: cf. above
          !call collect_block(xscr(idxopsscr),xop2,
          call collect_block_impr(xscr(idxopsscr),xop2,
          !call collect_block_t(xscr(idxopsscr),xop2,
     &         istr_cnta_bst,istr_cnta_bnd,nstr_cnta_tot, ! CA exchanged !
     &         istr_cntc_bst,istr_cntc_bnd,nstr_cntc_tot, ! CA exchanged !
     &         ncnt,.true.,
     &         1            ,nstr_ex2c_tot,nstr_ex2c_tot,
     &         1            ,nstr_ex2a_tot,nstr_ex2a_tot,
     &         nstr_ex2c_tot*nstr_ex2a_tot,
     &         map_ex2cntc,map_ex2cnta,
     &         ncblk_op2,nablk_op2,
     &         ldim_op2c,ldim_op2a,
     &         nablk_cnt,ncblk_cnt,      ! CA exchanged !
     &         ncblk_ex2,nablk_ex2,
     &         lstr_cnt(ncblk_cnt+1),lstr_cnt,    ! CA exchanged !
     &         lstr_ex2,lstr_ex2(ncblk_ex2+1),
     &         nstr_cnta2,nstr_cntc2,    ! CA exchanged !
     &         nstr_ex2c2,nstr_ex2a2,
     &         ireo_cnta2,ireo_cntc2,    ! CA exchanged !
     &         ireo_ex2c2,ireo_ex2a2)
        end if

c        call atim_cs(cpu,sys)
        cnt_coll1(1) = cnt_coll1(1)+cpu-cpu0
        cnt_coll1(2) = cnt_coll1(2)+sys-sys0

        if (ntest.ge.1000) then
          write(lulog,*) ncnt,nstr_exsc_tot*nstr_exsa_tot
          if (op1shorter)      write(lulog,*) 'resorted operator 1'
          if (.not.op1shorter) write(lulog,*) 'resorted operator 2'
          call wrtmat2(xscr(idxopsscr),ncnt,nstr_exsc_tot*nstr_exsa_tot,
     &                                 ncnt,nstr_exsc_tot*nstr_exsa_tot)
        end if

c dbg
c        call atim_cs(cpu2,sys2)
c dbg
        ! OMP: parallelize over this loop
        ! loop over blocks of EX_LONG
        do exl_batch = 1, n_exl_batch

          call idxstnd_batch(nexl,
     &         istr_exlc_bst,istr_exla_bst,
     &         istr_exlc_bnd,istr_exla_bnd,
     &         exl_batch,nstr_exlc_tot,nstr_exla_tot,
     &         maxlen_exl_batch)

          if (ntest.ge.1000) then
            write(lulog,*) '  exl_batch: ',exl_batch
            write(lulog,*) '  maxlen_exl_batch: ',maxlen_exl_batch
            write(lulog,*) '  nexl = ',nexl
            write(lulog,*) '  istr_exlc_bst,istr_exla_bst:',
     &           istr_exlc_bst,istr_exla_bst
            write(lulog,*) '  istr_exlc_bnd,istr_exla_bnd:',
     &           istr_exlc_bnd,istr_exla_bnd
          end if

c          call atim_cs(cpu0,sys0)

          ! resort OpLONG -> (CNT,EX_LONG) for current block
          if (op1shorter) then
            !call collect_block(xscr(idxoplscr),xop2,
            call collect_block_impr(xscr(idxoplscr),xop2,
            !call collect_block_t_i(xscr(idxoplscr),xop2,
     &         istr_cnta_bst,istr_cnta_bnd,nstr_cnta_tot, ! CA exchanged !
     &         istr_cntc_bst,istr_cntc_bnd,nstr_cntc_tot, ! CA exchanged !
     &         ncnt,.true.,
     &         istr_exlc_bst,istr_exlc_bnd,nstr_exlc_tot,
     &         istr_exla_bst,istr_exla_bnd,nstr_exla_tot,
     &         nexl,
     &         map_ex2cntc,map_ex2cnta,
     &         ncblk_op2,nablk_op2,
     &         ldim_op2c,ldim_op2a,
     &         nablk_cnt,ncblk_cnt,      ! CA exchanged !
     &         ncblk_ex2,nablk_ex2,
     &         lstr_cnt(ncblk_cnt+1),lstr_cnt,    ! CA exchanged !
     &         lstr_ex2,lstr_ex2(ncblk_ex2+1),
     &         nstr_cnta2,nstr_cntc2,    ! CA exchanged !
     &         nstr_ex2c2,nstr_ex2a2,
     &         ireo_cnta2,ireo_cntc2,    ! CA exchanged !
     &         ireo_ex2c2,ireo_ex2a2)
          else
            !call collect_block(xscr(idxoplscr),xop1,
            call collect_block_impr(xscr(idxoplscr),xop1,
            !call collect_block_n_i(xscr(idxoplscr),xop1,
     &         istr_cntc_bst,istr_cntc_bnd,nstr_cntc_tot,
     &         istr_cnta_bst,istr_cnta_bnd,nstr_cnta_tot,
     &         ncnt,.false.,
     &         istr_exlc_bst,istr_exlc_bnd,nstr_exlc_tot,
     &         istr_exla_bst,istr_exla_bnd,nstr_exla_tot,
     &         nexl,
     &         map_ex1cntc,map_ex1cnta,
     &         ncblk_op1,nablk_op1,
     &         ldim_op1c,ldim_op1a,
     &         ncblk_cnt,nablk_cnt,
     &         ncblk_ex1,nablk_ex1,
     &         lstr_cnt,lstr_cnt(ncblk_cnt+1),
     &         lstr_ex1,lstr_ex1(ncblk_ex1+1),
     &         nstr_cntc1,nstr_cnta1,
     &         nstr_ex1c1,nstr_ex1a1,
     &         ireo_cntc1,ireo_cnta1,
     &         ireo_ex1c1,ireo_ex1a1)
          end if
          if (ntest.ge.1000) then
            if (op1shorter)      write(lulog,*) 'resorted operator 2'
            if (.not.op1shorter) write(lulog,*) 'resorted operator 1'
            call wrtmat2(xscr(idxoplscr),ncnt,nexl,ncnt,nexl)
          end if

c          call atim_cs(cpu,sys)
c          cnt_coll2(1) = cnt_coll2(1)+cpu-cpu0
c          cnt_coll2(2) = cnt_coll2(2)+sys-sys0

          ! loop over blocks of EX_SHORT
c dbg
c          call atim_cs(cpu3,sys3)
c dbg
          do exs_batch = 1, n_exs_batch

            call idxstnd_batch(nexs,
     &         istr_exsc_bst,istr_exsa_bst,
     &         istr_exsc_bnd,istr_exsa_bnd,
     &         exs_batch,nstr_exsc_tot,nstr_exsa_tot,
     &         maxlen_exs_batch)

            if (ntest.ge.1000) then
              write(lulog,*) '    exs_batch: ',exs_batch
              write(lulog,*) '    maxlen_exs_batch: ',maxlen_exs_batch
              write(lulog,*) '    nexs = ',nexs
              write(lulog,*) '    istr_exsc_bst,istr_exsa_bst:',
     &             istr_exsc_bst,istr_exsa_bst
              write(lulog,*) '    istr_exsc_bnd,istr_exsa_bnd:',
     &             istr_exsc_bnd,istr_exsa_bnd
            end if

c dbg
c            call atim_cs(cpu4,sys4)
c dbg
            if (op1shorter) then

c              call atim_cs(cpu0,sys0)
c stat
              mm_call = mm_call+1
              mm_dim1   = mm_dim1  +nexs
              mm_dim1sq = mm_dim1sq+nexs*nexs
              mm_dim2   = mm_dim2  +nexl
              mm_dim2sq = mm_dim2sq+nexl*nexl
              mm_cnt    = mm_cnt   +ncnt
              mm_cntsq  = mm_cntsq +ncnt*ncnt
c stat

              ! calculate Op1Op2(EX_SHORT,EX_LONG)
              idx = idxopsscr + (exs_batch-1)*maxlen_exs_batch*ncnt
              call dgemm('t','n',nexs,nexl,ncnt,
     &             xfac,xscr(idx),ncnt,
     &                  xscr(idxoplscr),ncnt,
     &              0d0,xscr(idxop1op2scr),nexs)

c              call atim_cs(cpu,sys)
c              cnt_dgemm(1) = cnt_dgemm(1)+cpu-cpu0
c              cnt_dgemm(2) = cnt_dgemm(2)+sys-sys0

              if (ntest.ge.1000) then
                write(lulog,*) 'result (fac was ',xfac,')'
                call wrtmat2(xscr(idxop1op2scr),nexs,nexl,nexs,nexl)
              end if

c              call atim_cs(cpu0,sys0)

              ! resort Op1Op2
              ! OMP: must first collect lists, scatter to xop1op2 later
              call scatter_block(xop1op2,xscr(idxop1op2scr),
     &             istr_exsc_bst,istr_exsc_bnd,nstr_exsc_tot,
     &             istr_exsa_bst,istr_exsa_bnd,nstr_exsa_tot,
     &             nexs,
     &             istr_exlc_bst,istr_exlc_bnd,nstr_exlc_tot,
     &             istr_exla_bst,istr_exla_bnd,nstr_exla_tot,
     &             nexl,
     &             map_ex1ex2c,map_ex1ex2a,
     &             ncblk_op1op2,nablk_op1op2,
     &             ldim_op1op2c,ldim_op1op2a,
     &             ncblk_ex1,nablk_ex1,
     &             ncblk_ex2,nablk_ex2,
     &             lstr_ex1,lstr_ex1(ncblk_ex1+1),
     &             lstr_ex2,lstr_ex2(ncblk_ex2+1),
     &             nstr_ex1c12,nstr_ex1a12,
     &             nstr_ex2c12,nstr_ex2a12,
     &             ireo_ex1c12,ireo_ex1a12,
     &             ireo_ex2c12,ireo_ex2a12,
     &             istrscr1_c,istrscr1_a,
     &             istrscr2_c,istrscr2_a)

c              call atim_cs(cpu,sys)
              cnt_dgemm(1) = cnt_scatt(1)+cpu-cpu0
              cnt_dgemm(2) = cnt_scatt(2)+sys-sys0

            else

c              call atim_cs(cpu0,sys0)
c stat
              mm_call = mm_call+1
              mm_dim1   = mm_dim1  +nexl
              mm_dim1sq = mm_dim1sq+nexl*nexl
              mm_dim2   = mm_dim2  +nexs
              mm_dim2sq = mm_dim2sq+nexs*nexs
              mm_cnt    = mm_cnt   +ncnt
              mm_cntsq  = mm_cntsq +ncnt*ncnt
c stat

              ! calculate Op1Op2(EX_LONG,EX_SHORT)
              idx = idxopsscr + (exs_batch-1)*maxlen_exs_batch*ncnt
              call dgemm('t','n',nexl,nexs,ncnt,
     &             xfac,xscr(idxoplscr),ncnt,
     &                  xscr(idx),ncnt,
     &              0d0,xscr(idxop1op2scr),nexl)

c              call atim_cs(cpu,sys)
c              cnt_dgemm(1) = cnt_dgemm(1)+cpu-cpu0
c              cnt_dgemm(2) = cnt_dgemm(2)+sys-sys0

              if (ntest.ge.1000) then
                write(lulog,*) 'result (fac was ',xfac,')'
                call wrtmat2(xscr(idxop1op2scr),nexl,nexs,nexl,nexs)
              end if

c              call atim_cs(cpu0,sys0)

              ! resort Op1Op2
              ! OMP: see above
              call scatter_block(xop1op2,xscr(idxop1op2scr),
     &             istr_exlc_bst,istr_exlc_bnd,nstr_exlc_tot,
     &             istr_exla_bst,istr_exla_bnd,nstr_exla_tot,
     &             nexl,
     &             istr_exsc_bst,istr_exsc_bnd,nstr_exsc_tot,
     &             istr_exsa_bst,istr_exsa_bnd,nstr_exsa_tot,
     &             nexs,
     &             map_ex1ex2c,map_ex1ex2a,
     &             ncblk_op1op2,nablk_op1op2,
     &             ldim_op1op2c,ldim_op1op2a,
     &             ncblk_ex1,nablk_ex1,
     &             ncblk_ex2,nablk_ex2,
     &             lstr_ex1,lstr_ex1(ncblk_ex1+1),
     &             lstr_ex2,lstr_ex2(ncblk_ex2+1),
     &             nstr_ex1c12,nstr_ex1a12,
     &             nstr_ex2c12,nstr_ex2a12,
     &             ireo_ex1c12,ireo_ex1a12,
     &             ireo_ex2c12,ireo_ex2a12,
     &             istrscr1_c,istrscr1_a,
     &             istrscr2_c,istrscr2_a)

c              call atim_cs(cpu,sys)
c              cnt_scatt(1) = cnt_scatt(1)+cpu-cpu0
c              cnt_scatt(2) = cnt_scatt(2)+sys-sys0

            end if

            if (ntest.ge.1000) then
              write(lulog,*) 'updated OP1OP2: (first element): ',
     &             xop1op2(1)
            end if
c dbg
c            call atim_cs(cpu,sys)
c            cnt_test(11) = cnt_test(11)+cpu-cpu4
c            cnt_test(12) = cnt_test(12)+sys-sys4
c dbg

          end do
c dbg
c          call atim_cs(cpu,sys)
c          cnt_test(9)  = cnt_test(9)+cpu-cpu3
c          cnt_test(10) = cnt_test(10)+sys-sys3
c dbg

        end do

        ! OMP: final scattering to xop1op2: here
c dbg
c        call atim_cs(cpu,sys)
c        cnt_test(7) = cnt_test(7)+cpu-cpu2
c        cnt_test(8) = cnt_test(8)+sys-sys2
c dbg

      end do

c dbg
c      call atim_cs(cpu,sys)
c      cnt_test(5) = cnt_test(5)+cpu-cpu1
c      cnt_test(6) = cnt_test(6)+sys-sys1
c      cnt_test(1) = cnt_test(1)+cpu-cpu00
c      cnt_test(2) = cnt_test(2)+sys-sys00
c dbg
      return
      end


module geoclim_create_output_mod
implicit none

contains

subroutine geoclim_create_output(ID, output_path, run_name, vol, surf, surf_sedi, fname, fnum, varname, missval)
  use io_module, only: read_io_condition
  use netcdf_io_module, only: create, def_dim, def_var, put_att_text, put_att_real, enddef, redef, put_var_real1D, &
                              put_var_int1D, close_file
  use netcdf
  include 'coupler.inc'
  integer, parameter:: nvar=107
  integer, intent(in):: ID
  character(len=*), intent(in):: output_path, run_name
  double precision, dimension(:), intent(in):: vol, surf, surf_sedi
  !
  integer, intent(out), dimension(nvar):: fnum
  character(len=*), intent(out), dimension(nvar) :: fname, varname
  double precision, intent(out), dimension(nvar):: missval
  character(len=100), dimension(nvar) :: varunits, missvalname
  character(len=500), dimension(nvar) :: var_longname
  !
  integer, dimension(nvar) :: fid, varid
  !
  integer, parameter:: maxlgth=500
  character(len=maxlgth):: dummy
  integer:: nbasin, nlon, nlat, dimid(nvar,2)
  integer:: i, j, k

  ! Default name and value of missing-values (if unspecified in text input files)
  character(len=*), parameter:: defmissvalname = '_FillValue'
  double precision, parameter:: defmissval = 9.96921e+36

  !===================================== OUTPUT VARIABLES LIST: =====================================!
  !  OUTPUT: box, time, vol, surf, surf_sed, DIC, alk, PO4, Ca, Sr, SrPIC, POP, PIP, POC, PIC, O2,   !
  !  var #:  1    2     3    4     5         6    7    8    9   10  11     12   13   14   15   16    !
  !          PCO2,    DICd13C, PICd13C, POCd13C, CO2d13C, SrISO, PICSrISO, d7Li, Li, H2CO3, HCO3,    !
  !          17       18       19       20       21       22     23        24    25  26     27       !
  !          CO3, H2CO3d13C, HCO3d13C, CO3d13C, pH, omega, temp, salin, dplysc, dplysa, DIC_G,       !
  !          28   29         30        31       32  33     34    35     36      37      38           !
  !          alk_G, PO4_G, Ca_G, Sr_G, SrPIC_G, POP_G, PIP_G, POC_G, PIC_G, O2_G, DICd13C_G,         !
  !          39     40     41    42    43       44     45     46     47     48    49                 !
  !          PICd13C_G, POCd13C_G, SrIOS_G, PICSrISO_G, d7Li_G, Li_G, pH_G, omega_G, temp_G,         !
  !          50         51         52       53          54      55    56    57       58              !
  !          salin_G, O2_LEV, CO2_LEV, O2_CON, CO2_CON, xPOPex, fCO2anth, FCO2AO, FCO2AO_tot,        !
  !          59       60      61       62      63       64      65        66      67                 !
  !          finorgC, Fdisscarb, Fsilw, Fbasw, Fcarbw, Fkerw, freef, freef_tot, fdep_tot, Fodc,      !
  !          68       69         70     71     72      73     74     75         76        77         !
  !          Fodc_tot, Fsinkinorg, FPw, fbioC, FseaflrCdiss, FseaflrCdiss_tot, ftrap, fCO2crust,     !
  !          78        79          80   81     82            83                84     85             !
  !          FSO4basin, FSO4crust, LiFriv, Lidriv, total_cont_POC_export, degassing, discharge, TSS, !
  !          86         87         88      89      90                     91         92         93   !
  !          epsi_C, epsi_C_cont, GMST, sed_rate, sed_flux, Corg_BE, fodp, fphos, fhydP, fPyrWth,    !
  !          94      95           96    97        98        99       100   101    102    103         !
  !          fSilSulfW, fCarbSulfW, fSulfRed, fO2_odc                                                !
  !          104        105         106       107                                                    !
  !==================================================================================================!

  integer, dimension(nvar), parameter:: indice_boxdef = &
          (/ 0,0,1,1,1, 1,1,1,1,1,   1,1,1,1,1, 1,1,1,1,1,   1,1,1,1,1, 1,1,1,1,1,   1,1,1,1,1, 1,1,0,0,0, & !#40
             0,0,0,0,0, 0,0,0,0,0,   0,0,0,0,0, 0,0,0,0,0,   0,0,0,0,0, 1,0,1,0,0,   0,0,0,1,0, 0,1,0,1,0, & !#80
             1,1,0,0,1, 1,1,0,0,0,   0,0,0,1,0, 0,1,1,1,1,   1,1,0,0,0, 1,1                                /)

  ! default missing-value
  missvalname = defmissvalname
  missval = defmissval

  ! get number of basin
  nbasin = size(surf,1)

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%!
!%                                   getting output file names:                                   %!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%!

  ! read variables attributes (#1 to #nvar)
  do i=1,5
    call read_io_condition(ID, fname(i) , varname(i) , varunits(i) )
  end do
  do i=6,nvar
    call read_io_condition(ID, fname(i) , varname(i) , varunits(i) , missvalname(i)  , missval(i) , var_longname(i) )
  end do

  do i=2,nvar
  ! replace "-" by previous line's file name
    dummy = fname(i)
    if (dummy(1:1) == '-') then
      dummy=''
      j = i
      do while (dummy=='')
        j = j-1
        dummy = fname(j)
      end do
      fname(i) = dummy
    else
      if (dummy(1:1) /= '#') then
        ! add output directory path and extension:
        fname(i) = trim(output_path)//trim(dummy)//trim(run_name)//'.nc'
      else
        fname(i) = ''
      end if
    end if
  end do

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%!
!%                                    output file definition:                                     %!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%!

  ! Check the number of different files:
  !-------------------------------------

  fnum(6) = 6 ! the first 5 variables are dimensions variables + volume + surface, and don't need a file
  do k = 6,nvar  ! loop on all file names
    i = 1
    do while ( fname(k) /= fname(i) ) ! loop on all previous file names
      i = i + 1
    end do
    fnum(k) = i
  end do
  do k = 1,nvar
    if (fname(k)=='') then
      ! "#" file name => don't write this variable
      ! => put 0, so that it will not be created
      fnum(k) = 0
    end if
  end do

  ! Output file creation:
  !---------------------

  k = 0
  do i = 6,nvar
    if ( fnum(i) > k ) then ! if "new" file

      call create(fname(i), fid(i))
      k = fnum(i)

      ! GOBAL ATTRIBUTES
      call put_att_text(fid(i), (/NF90_GLOBAL/), (/'title'/),                       (/'COMBINE module ouputs'/))
      call put_att_text(fid(i), (/NF90_GLOBAL/), (/'run_name'/),                    (/trim(run_name)/))
      if (coupling_ecogeo) then
        call put_att_text(fid(i), (/NF90_GLOBAL/), (/'marine_ecology_module'/),     (/'on'/))
      else
        call put_att_text(fid(i), (/NF90_GLOBAL/), (/'marine_ecology_module'/),     (/'off'/))
      endif
      if (coupling_dynsoil) then
        call put_att_text(fid(i), (/NF90_GLOBAL/), (/'silicate_weathering_model'/), (/'DynSoil'/))
        if (use_dynsoil_steady_state) then
          call put_att_text(fid(i), (/NF90_GLOBAL/), (/'DynSoil_mode'/),            (/'steady-state'/))
        else
          call put_att_text(fid(i), (/NF90_GLOBAL/), (/'DynSoil_mode'/),            (/'dynamic'/))
        end if
      else
        call put_att_text(fid(i), (/NF90_GLOBAL/), (/'silicate_weathering_model'/), (/'old'/))
      endif
      call put_att_text(fid(i), (/NF90_GLOBAL/), (/'CO2_interpolation'/),           (/interpolation_mode/))

    elseif(fnum(i)/=0) then
      fid(i) = fid(fnum(i))

    else
      fid(i) = 0

    end if
  end do

  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
  ! Dimensions and dimension variables (definition, attribute, and putting): !
  ! [need to be defined as many time as different files]                     !
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!

  ! box dimension and variable
  !---------------------------

  k = 0
  do i = 6,nvar ! loop on box-defined variables (except axes, volume and surfaces)
    if (indice_boxdef(i)==1) then

      if ( fnum(i) > k ) then ! if "new" file

        call def_dim( fid(i), varname(1:1), (/nbasin/) , dimid(i,1:1) )
        call def_var( fid(i), varname(1:1), (/NF90_INT/), dimid(i,1:1), varid(1:1)    )
        ! dimension variables attributes:
        call put_att_text( fid(i), varid(1:1), (/'axis'/), (/'Y'/)        )
        ! Variable attributes:
        call put_att_text( fid(i), varid(1:1), (/'name'/) , varname(1:1)  )
        call put_att_text( fid(i), varid(1:1), (/'units'/), varunits(1:1) )
        call put_att_text( fid(i), varid(1:1), (/'box_1'/),  (/'polar N surf'/) )
        call put_att_text( fid(i), varid(1:1), (/'box_2'/),  (/'polar N deep'/) )
        call put_att_text( fid(i), varid(1:1), (/'box_3'/),  (/'mid-lat surf'/) )
        call put_att_text( fid(i), varid(1:1), (/'box_4'/),  (/'thermocline'/)  )
        call put_att_text( fid(i), varid(1:1), (/'box_5'/),  (/'mid-lat deep'/) )
        call put_att_text( fid(i), varid(1:1), (/'box_6'/),  (/'epicont surf'/) )
        call put_att_text( fid(i), varid(1:1), (/'box_7'/),  (/'epicont deep'/) )
        call put_att_text( fid(i), varid(1:1), (/'box_8'/),  (/'polar S surf'/) )
        call put_att_text( fid(i), varid(1:1), (/'box_9'/),  (/'polar S deep'/) )
        call put_att_text( fid(i), varid(1:1), (/'box_10'/), (/'atmosphere'/)   )

        do j = fnum(i),i-1 ; if (fnum(j)==fnum(i)) dimid(j,1) = dimid(i,1) ; end do

        k = fnum(i)

      elseif(fnum(i)/=0) then ! if "old" file
        dimid(i,1) = dimid(fnum(i),1)
      end if

    end if
  end do

  ! time dimension and variable:
  !-----------------------------

  k = 0
  do i = 6,nvar ! loop on all variables (except axes and volume)

    if ( fnum(i) > k ) then ! if "new" file

      ! time dimension (all variables are time-defined):
      call def_dim( fid(i), varname(2:2), (/NF90_UNLIMITED/) , dimid(i,2:2) )
      call def_var( fid(i), varname(2:2), (/NF90_FLOAT/), dimid(i,2:2), varid(2:2)    )
      ! dimension variables attributes:
      call put_att_text( fid(i), varid(2:2), (/'axis'/), (/'T'/)        )
      ! Variable attributes:
      call put_att_text( fid(i), varid(2:2), (/'name'/) , varname(2:2)  )
      call put_att_text( fid(i), varid(2:2), (/'units'/), varunits(2:2) )

      k = fnum(i)

    elseif(fnum(i)/=0) then ! if "old" file
      dimid(i,2) = dimid(fnum(i),2)
    end if

  end do

  ! volume and surface variable:
  !-----------------------------

  k = 0
  do i = 6,nvar ! loop on box-defined variables (except axes and volume)
    if (indice_boxdef(i)==1) then

      if ( fnum(i) > k ) then ! if "new" file

        call def_var( fid(i), varname(3:3), (/NF90_FLOAT/), dimid(i,1:1), varid(3:3)    )
        call put_att_text( fid(i), varid(3:3), (/'name'/) , varname(3:3)  )
        call put_att_text( fid(i), varid(3:3), (/'units'/), varunits(3:3) )

        call def_var( fid(i), varname(4:4), (/NF90_FLOAT/), dimid(i,1:1), varid(4:4)    )
        call put_att_text( fid(i), varid(4:4), (/'name'/) , varname(4:4)  )
        call put_att_text( fid(i), varid(4:4), (/'units'/), varunits(4:4) )

        call def_var( fid(i), varname(5:5), (/NF90_FLOAT/), dimid(i,1:1), varid(5:5)    )
        call put_att_text( fid(i), varid(5:5), (/'name'/) , varname(5:5)  )
        call put_att_text( fid(i), varid(5:5), (/'units'/), varunits(5:5) )

        k = fnum(i)

      end if

    end if
  end do

  !++++++++++++++++++++++++++++++++++++++++++++++++++++!
  ! Other variables [need to be defined one time only] !
  !++++++++++++++++++++++++++++++++++++++++++++++++++++!

  ! Variables definition:
  !----------------------

  do i = 6,nvar
    if (fnum(i)==0) then ! => not writing this variable
      fid(i) = 0
      varid(i) = 0
    else
      if (indice_boxdef(i)==0) then ! if box-defined variable:
        call def_var( fid(i), varname(i:i), (/NF90_FLOAT/), dimid(i,2:2), varid(i:i) )
      else
        call def_var( fid(i), varname(i:i), (/NF90_FLOAT/), dimid(i,1:2), varid(i:i) )
      end if
    end if
  end do

  ! Variables attributes:
  !----------------------

  do i = 6,nvar
    if (fnum(i)/=0) then ! if variable has to be written
      call put_att_text( fid(i), varid(i:i), (/'name'/) , varname(i:i)             )
      call put_att_text( fid(i), varid(i:i), (/'units'/), varunits(i:i)            )
      call put_att_real( fid(i), varid(i:i), missvalname(i:i) , real(missval(i:i)) )
      if (.not. (var_longname(i) == '')) then
          call put_att_text(fid(i), varid(i:i), (/'long_name'/), var_longname(i:i) )
      end if
    end if
  end do

  ! end of denifition :
  !--------------------

  k = 0
  do i = 6,nvar
    if (fnum(i) > k) then ! if "new" file
      call enddef(fid(i))
      k = fnum(i)
    end if
  end do

  ! put box, volume and surface variables:
  !---------------------------------------

  k = 0
  do i = 6,nvar
    if (indice_boxdef(i)==1) then
      if ( fnum(i) > k ) then ! if "new" file
        call put_var_int1D( fid(i), varid(1), (/(j,j=1,nbasin)/) )
        call put_var_real1D( fid(i), varid(3), real(vol(1:nbasin)) )
        call put_var_real1D( fid(i), varid(4), real(surf) )
        call put_var_real1D( fid(i), varid(5), real(surf_sedi) )
        k = fnum(i)
      end if
    end if
  end do

  ! close output file(s):
  !----------------------

  k = 0
  do i = 6,nvar
    if (fnum(i) > k) then ! if "new" file
      call close_file(fid(i))
      k = fnum(i)
    end if
  end do

end subroutine

end module