      subroutine iff_feffit(str)
c
c given a list of paths and data, fit sum of paths to data
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1997--2000 Matthew Newville, The University of Chicago
c Copyright (c) 1992--1996 Matthew Newville, University of Washington
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, The University of Washington, or the authors
c appear in advertising or endorsement of works derived from this
c software without specific prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
       implicit none
       include 'consts.h'
       include 'keywrd.h'
       include 'arrays.h'
       include 'fft.h'
       include 'fefdat.h'
       include 'pthpar.h'
       include 'feffit.h'
       save

       double precision  toldef, epsmin, p01
       parameter (toldef = 1.d-7, epsmin = 1.d-8, p01 = 1.d-2)
       integer   lenwrk,  lenfvc
       parameter(lenwrk = 2*maxpts*mvarys + 20*mvarys + 2*maxpts)
       parameter(lenfvc = 2*maxpts)

       logical  do_pha, do_mag, do_re, isnum, dofit, do_bkg
       character*512 str*(*), pref
       character*512 name1(mdata), nam_chi(mdata), nam_x(mdata)
       character*512 re_arr, xk_arr, winarr, winnam, fit_sp, fit_mode
       character*1024 list, cmdstr

       integer  idata, jchi, ier, illen, jk,  ilen, jwin, n1, n2
       integer  istrln, k, i, jprint, nerstp, idx, ntmp, iup
       integer  nkpts,  np, u2ipth, lminfo, nfit1, j1, j0, j2
       integer  iwork(mvarys), ibadx(mvarys), ipos, jxk, ntchi, isp
       integer  ipath_tmp(max_pathindex)
       integer  get_array, imac_tmp, j, jqw, ntbkg
       logical  iftmac, isasca, isamac, uniq_dat
       double precision  xkmin, xkmax, dk1, dk2, xkw, getsca,q, chired
       double precision  xrmin, xrmax, toler, xolow, xohigh, tmp
       double precision  work(lenwrk), fvect(lenfvc), ftemp(lenfvc)
       double precision  fjac(lenfvc, mvarys), tmpchi(maxpts)
       double precision  alpha(mvarys, mvarys), varys(mvarys), small
       double precision  qbkg1, qbkg2, bvalue,xspl(mtknot), qx
       double precision  xkdat(maxpts), xcdat(maxpts), xwdat(maxpts)
       double precision  tmparr2(maxpts)
       double precision  wtmp, stmp, sumsqr, xidat, eps_k, eps_r
       double precision  qw_tmp(mqwfs), sum2chi(mdata)
       character*128     restr_tmp(max_restraint)
       integer  nrest_tmp
       integer  iff_eval, iff_eval_dp, iff_eval_in, nqw

       external iff_eval, iff_eval_dp, iff_eval_in, bvalue
       external istrln, u2ipth, isnum,  fitfun, getsca, sumsqr
       external isasca, isamac, get_array

       toler = zero
c
       fit_macro = undef
       fit_m_arg = ' '
       ifit_mac  = -1
       nerstp= 1
       j0    = 0
       jprint= 0
       xrmin = getsca('rmin',1)
       xrmax = getsca('rmax',1)
       xkmin = getsca('kmin',1)
       xkmax = getsca('kmax',1)
       xkw   = getsca('kweight',1)
       dk1   = getsca('dk1',1)
       dk2   = getsca('dk2',1)
       xidat = getsca('data_set',1)
       idata = int(xidat)
       if (idata.le.0) idata = 1
       xidat = getsca('data_total',1)
       nfdats= int(xidat)
       eps_k = zero
       eps_r = zero
       xk_arr= undef
       winarr= undef
       pref  = undef
       call gettxt('kwindow', winnam)
       call gettxt('fit_space',fit_sp)
       fit_mode = 'ri'
ccc       call gettxt('fit_mode',fit_mode)

c  interpret any and all keyword/value pairs for setting options
       call bkeys(str, mkeys, keys, values, nkeys)
       np     =  0
       illen  =  1
       list   =  ' '
       do_re  = .false.
       do_mag = .false.
       do_pha = .false.
       do_bkg = .false.

       nqw = 0
       qw_tmp(1) = getsca('kweight',1)
       do 10 i = 2, mqwfs
          qw_tmp(i) = zero
 10    continue
       nrest_tmp = 0

       do 100 i = 1, nkeys
          k = istrln( keys(i))
          if ((keys(i).eq.'prefix').or.(keys(i).eq.'group')) then
             pref  = values(i)
             call smcase(pref,'a')
          elseif (keys(i).eq.'data_set') then
             ier   = iff_eval_dp(values(i), xidat)
             idata = int(xidat)
             name1(idata) = undef
             call setsca('data_set', xidat)
             nfit(idata) = 0
          elseif (keys(i).eq.'data_total') then
             ier = iff_eval_dp(values(i), xidat)
             nfdats = int(xidat)
             call setsca('data_total', xidat)
          elseif (keys(i).eq.'macro') then
             fit_macro = values(i)
          elseif ((keys(i).eq.'macro_arg')) then
             fit_m_arg = values(i)
          elseif (keys(i)(1:9).eq.'restraint') then
             nrest_tmp = nrest_tmp+1
             if (idata.le.0)  idata = 0
             if (nrest_tmp.gt.max_restraint) then
                call echo(" *** feffit:: too many restraints")
                call echo("     restraint will be ignored:")
                call warn(1,"      " // values(i))
                values(i) = ''
             endif
             if((values(i).ne.'').and.(values(i).ne.undef)) then
                restr_tmp(nrest_tmp) = values(i)
cc                print*, ' Feffit restraint : ', idata
cc                print*,  nrest_tmp, values(i)(:60)
             endif
          elseif ((keys(i).eq.'rmin')) then
             ier = iff_eval_dp(values(i), xrmin)
          elseif ((keys(i).eq.'rmax')) then
             ier = iff_eval_dp(values(i), xrmax)
          elseif ((keys(i).eq.'kmax')) then
             ier = iff_eval_dp(values(i), xkmax)
          elseif ((keys(i).eq.'kmin')) then
             ier = iff_eval_dp(values(i), xkmin)
          elseif ((keys(i).eq.'error_step')) then
             ier = iff_eval_in(values(i), nerstp)
          elseif ((keys(i).eq.'error_print')) then
             ier = iff_eval_in(values(i), jprint)
          elseif (keys(i).eq.'kwindow') then
             winnam = values(i)
          elseif (keys(i).eq.'altwindow') then
             winarr = values(i)
             call lower(winarr)
          elseif (keys(i).eq.'kweight') then
             nqw = nqw + 1
             ier = iff_eval_dp(values(i), xkw)
             if ((nqw.ge.1).and.(nqw.le.mqwfs)) then
                qw_tmp(nqw) = xkw
             endif
          elseif (keys(i).eq.'dk1') then
             ier = iff_eval_dp(values(i), dk1)
          elseif (keys(i).eq.'dk2') then
             ier = iff_eval_dp(values(i), dk2)
          elseif (keys(i).eq.'dk') then
             ier = iff_eval_dp(values(i), dk1)
             dk2 = dk1
          elseif (keys(i).eq.'chi') then
             re_arr = values(i)
             call lower(re_arr)
          elseif (keys(i).eq.'k') then
             xk_arr = values(i)
             call lower(xk_arr)
          elseif ((keys(i).eq.'epsilon_k')) then
             ier = iff_eval_dp(values(i), eps_k)
          elseif ((keys(i).eq.'epsilon_r')) then
             ier = iff_eval_dp(values(i), eps_r)
          elseif ((keys(i).eq.'fit_space')) then
             fit_sp = values(i)
          elseif ((keys(i).eq.'fit_mode')) then
             fit_mode = values(i)
          elseif ((keys(i).eq.'do_real')) then
             call str2lg(values(i), do_re, ier)
          elseif ((keys(i).eq.'no_real')) then
             call str2lg(values(i), do_re, ier)
             do_re = .not. do_re
          elseif ((keys(i).eq.'do_mag')) then
             call str2lg(values(i), do_mag, ier)
          elseif ((keys(i).eq.'no_mag')) then
             call str2lg(values(i), do_mag, ier)
             do_mag = .not. do_mag
          elseif ((keys(i).eq.'do_phase')) then
             call str2lg(values(i), do_pha, ier)
          elseif ((keys(i).eq.'no_phase')) then
             call str2lg(values(i), do_pha, ier)
             do_pha = .not. do_pha
          elseif ((keys(i).eq.'do_all')) then
             call str2lg(values(i), do_re, ier)
             do_mag = do_re
             do_pha = do_re
          elseif ((keys(i).eq.'do_bkg')) then
             call str2lg(values(i), do_bkg, ier)
          elseif ((keys(i).eq.'toler')) then
             ier = iff_eval_dp(values(i), toler)
c
c path list:
          elseif (values(i).eq.undef) then
             call str2il(keys(i), max_pathindex, np, ipath_tmp,ier)
             if (ier .eq. 0) then
                jk    = istrln(keys(i))
                list  = list(1:illen)//keys(i)(1:jk)//','
                illen = illen+jk+1
             else
                call echo(' *** feffit: error generating path list')
                call warn(2, keys(i)(1:k))
             end if
          else
             call warn(1,' *** feffit: unknown key: '//keys(i)(1:k))
          end if
 100   continue
c===================================================================
c  done reading input params
       idata  = max(1, min(mdata, idata))
       nfdats = max(1, min(mdata, nfdats))
       dofit  = (idata.ge.nfdats)
       bkgfit(idata) = do_bkg
cc       print*, ' feffit: ', idata, bkgfit(idata)

cc       print*, ' __ feffit __ : idata, nfdats = ', idata, nfdats
c===================================================================
c for this data set:
c    resolve chi(k) name, get index of chi data
c    set fft / fit params
c    get eps_k and eps_r from iff_chieps (unless given explicitly!)
c    set path list

       name1(idata) = pref
       if (name1(idata) .eq. undef) name1(idata) = 'feffit'

       jchi  = get_array(re_arr, name1(idata), 0, xcdat)
       if (jchi.le.0) then
          call warn(2, ' feffit: no chi(k) data array?')
          return
       end if
c save name of re_arr for later
       nam_chi(idata) = re_arr
       nam_x(idata)   = undef
       call prenam(name1(idata),nam_chi(idata))
cc       print*, 'XXXX idata ', idata, nam_chi(idata)(1:30)
c
c if k-data is given, shift/interpolate input data onto
c fit k-grid: chi(1) = chi(k=0).

       if (xk_arr.ne.undef) then
          ipos = 0
          jxk  = get_array(xk_arr, name1(idata), 0, xkdat)
          nam_x(idata) = xk_arr
          call prenam(name1(idata),nam_x(idata))
          if (jxk.gt.0) then
             nkpts = min(jxk, jchi)
             ntchi = int(1 + xkdat(jxk)/qgrid)
             do 130 i = 1, ntchi
                q = (i-1) * qgrid
                call lintrp(xkdat, xcdat, nkpts, q,ipos,tmpchi(i))
 130         continue
          else
             call warn(2, ' feffit: bad k-data array?')
             return
          endif
       else
          nkpts = jchi
          ntchi = jchi
          do 150 i = 1, ntchi
             tmpchi(i) =  xcdat(i)
 150      continue
       endif
c save this chi(k) data to the appropriate array for fitfun,
c accumulate sum-of-squares for later uniqueness check
       sum2chi(idata) = zero
       do 170 i = 1, ntchi
          chiq(i,idata) = tmpchi(i)
          sum2chi(idata) = sum2chi(idata) + tmpchi(i)*tmpchi(i)
 170   continue
       do 175 i = ntchi+1,maxpts
          chiq(i,idata) = zero
 175   continue

c support for refining bkg(k) with EXAFS parameters
       if (bkgfit(idata)) then
          rbkg_f(idata) = xrmin
          xrmin       = zero
       endif
c
c  check if fit_macro call will work
       if (fit_macro.ne.undef) then
          ifit_mac = 0
          iftmac = isamac(fit_macro,ifit_mac)
          if (.not.iftmac) then
             cmdstr = '  fitting macro not found: '//fit_macro
             call warn(1,cmdstr)
             fit_macro = undef
             ifit_mac  = 0
          endif
          if (ifit_mac.gt.0) then
             nmac_stop = nmacro
             imac_tmp = imac
          endif
       endif
c
c  set up fft/fit parameters, initialize window functions
       small      = rgrid * p01
       n1         = int( (xrmin + small) / rgrid )  + 1
       n2         = int( (xrmax + small) / rgrid )
       if (n2.le.n1) n2 = n1 + 1
       nrpts(idata)  = n2 - n1 + 1
       rmax(idata)   = rgrid * n2
       rmin(idata)   = rgrid * n1
       dq1(idata)    = dk1
       dq2(idata)    = dk2
       small         = qgrid * p01
       n1            = int( (xkmin + small) / qgrid )  + 1
       n2            = int( (xkmax + small) / qgrid )
       if (n2.le.n1) n2 = n1 + 1
       nqpts(idata)  = n2 - n1 + 1
       qmax(idata)   = qgrid * n2
       qmin(idata)   = qgrid * n1
       nqfit(idata)  = int((qmax(idata) + 5*dq2(idata))/qgrid)

       xinfo(idata)  = 2 * ((rmax(idata)-rmin(idata))*
     $      (qmax(idata)-qmin(idata))) /pi
       if (bkgfit(idata)) then
          qbkg1       = max(zero,qgrid*n1 - dk1)
          qbkg2       = min(qgrid*n2 + dk2,  qgrid*nkpts)
          if (qbkg2 .le. (qbkg1 + 5*qgrid)) then
             qbkg2    = qbkg1 + 5 * qgrid
          endif
          ntbkg  = 1 + 2*int(rbkg_f(idata)*(qbkg2-qbkg1)/pi)
          ntbkg  = min(mtknot-korder-1,max(korder+1,ntbkg))
          nbkg(idata) = ntbkg
c-bkg where to put knots
          do 220 i = 1, korder
             qknot(i,idata)       =  qbkg1 - qgrid * (korder-i)
             qknot(ntbkg+i,idata) =  qbkg2 + qgrid * (i-1)
 220      continue
          ntmp   = ntbkg - korder + 1
          do 240 i = korder+1, ntbkg
             qknot(i, idata) = qbkg1 +(i-korder)*(qbkg2-qbkg1)/ntmp
 240      continue

c-bkg add spline coefs to the variable list, initialize to zero
          do 260  i = 1, ntbkg
             cmdstr = ' '
             write(cmdstr, 265)  'bkg',idata,'_',i,'  = 0.0'
             call iff_set('guess',cmdstr,1)
 260      continue
 265      format (a3,i2.2,a1,i2.2,a7)
          nvarys = nvarys + ntbkg
       else
          do 280  i = 1, ntbkg
 275         format (a3,i2.2,a1,i2.2)
             write(cmdstr, 275)  'bkg',idata,'_',i
             if (isasca(cmdstr)) then
                qx = getsca(cmdstr,0)
 285            format (a3,i2.2,a1,i2.2,a3,g15.9)
                write(cmdstr, 285)  'bkg',idata,'_',i,' = ',qx
                call iff_set('set', cmdstr,0)
             endif
 280      continue
       end if
c
c  which space is this fit in?
       ifft(idata)   = 1
       if (fit_sp(1:1) .eq.'k') ifft(idata) = 0
       if (fit_sp(1:1) .eq.'q') ifft(idata) = 2

       modeft(idata)   = 0
       if (fit_mode(1:2) .eq.'ri') modeft(idata) = 0
       if (fit_mode(1:2) .eq.'rm') modeft(idata) = 1

cc       print*, ' Feffit ', fit_sp, ifft(idata), idata
c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c-c
c
c set k-weight, including multiple k-weights
       if (nqw.le.0) nqw = 1
       nqwfs(idata) = nqw
       do 295 i = 1, mqwfs
          qwfs(i,idata) = qw_tmp(i)
 295   continue
       qweigh(idata) = qwfs(1,idata)

c loop over k-weights to set weight of fit
       do 450 jqw = nqw, 1, -1
          xkw = qwfs(jqw,idata)
c    determine eps_k/eps_r for this k-weight
c    call 'chieps ('chi_noise' command) to get eps_k / eps_r
          if ((eps_k .le. epsmin).and.(eps_r .le. epsmin)) then
             ilen = istrln(nam_chi(idata))
 405         format('  chi=',a,',kmin=',f12.3,',kmax=',f12.3,
     $            ',kweight=',f12.3,',dk1=',f12.3,',dk2=',f12.3)
             write(cmdstr, 405) nam_chi(idata)(1:ilen),
     $            xkmin, xkmax,xkw,dk1,dk2
             if (nam_x(idata) .ne. undef) then
                j0 = istrln(cmdstr)
                j2 = istrln(nam_x(idata))
                cmdstr = cmdstr(:j0)//', k='//nam_x(idata)(:j2)
             endif
             call iff_chieps(cmdstr)
             sigdtk  = getsca('epsilon_k',1)
             sigdtr  = getsca('epsilon_r',1)
          elseif (eps_k .gt. epsmin) then
             sigdtk  = eps_k
             wtmp    = 2 * xkw  + one
             sigdtr  = eps_k /  sqrt( 2 * pi * wtmp /
     $            (qgrid * (xkmax**wtmp - xkmin**wtmp )))
          elseif (eps_r .gt. epsmin) then
             sigdtr  = eps_r
             wtmp    = 2 * xkw  + one
             sigdtk  = eps_r *  sqrt( 2 * pi * wtmp /
     $            (qgrid * (xkmax**wtmp - xkmin**wtmp )))
          end if
          call setsca('epsilon_k', sigdtk)
          call setsca('epsilon_r', sigdtr)

c set number of fit points, data-set weight, and
c a few other misc stuff based on which fit space is used
          rweigh(idata) = one
c r-space fit
          if (ifft(idata).eq.1) then
             xolow      = rmin(idata)
             xohigh     = rmax(idata)
             nfit(idata)   = 2 * max (1, nrpts(idata))
             weight(jqw,idata) = sigdtr * sigdtr
          else
c q/k-space fit
             xolow      = qmin(idata)
             xohigh     = qmax(idata)
             nfit(idata)   = 2 * max (1, nqpts(idata))
             weight(jqw,idata) = sigdtk * sigdtk
c q-space fit
             if (ifft(idata).eq.2) then
                wtmp       = 2 * rweigh(idata)  + one
                stmp       = sqrt ( pi * wtmp /
     $               (rgrid * (xrmax**wtmp - xrmin**wtmp )))
                sigdtq     = sigdtr / stmp
                weight(jqw,idata) = sigdtq * sigdtq
             endif
          endif
          weight(jqw,idata) =  sqrt(nfit(idata) * weight(jqw,idata)
     $         /xinfo(idata))
          if (weight(jqw,idata).le.zero) weight(jqw,idata) = one
cc          print*, 'FIT WEIGHT: ', jqw, idata , weight(jqw,idata)
 450   continue
c
c set k-window
       if (winarr.eq.undef)  then
          call window(winnam,dk1,dk2,xkmin,xkmax,qgrid,maxpts,
     $         qwindo(1,idata))
       else
          jwin = get_array(winarr, name1(idata), 0,xwdat)
          if (jwin.le.0) then
             call warn(2,' feffit: no window array? looking for '
     $            //winarr)
             return
          end if
          if (xk_arr.ne.undef) then
             ipos = 0
             ntchi = int( 1 + xkdat(jxk)/qgrid )
             do 470 i = 1, ntchi
                q = (i-1) * qgrid
                call lintrp(xkdat, xwdat, maxpts,
     $               q, ipos, qwindo(i,idata))
 470         continue
          else
             ntchi = jwin
             do 480 i = 1, ntchi
                qwindo(i,idata) =  xwdat(i)
 480         continue
          endif
       end if
c set r-window
       call window('hann',zero,zero,xrmin,xrmax,rgrid,maxpts,
     $         rwindo(1,idata))

c convert list of path indices to iup array
       call str2il(list(1:illen), max_pathindex, np,
     $      ipath_tmp, ier)

       do i = 1, mpaths
          iulist(i,idata) = 0
       enddo
       iup= 0
       do i = 1, np
          if (u2ipth(ipath_tmp(i)).ge.1) then
             iup=iup+1
             iulist(iup,idata) = ipath_tmp(i)
          endif
       enddo
cc       print *, 'iulist ', idata, iup, np
cc       do i = 1, iup
cc          print*, iulist(i,idata)
cc       enddo
cc       print*,' idata ', idata, nrest_tmp
       nrestraint(idata) = nrest_tmp
       do 570 i = 1, nrest_tmp
          restraint(i,idata) = restr_tmp(i)
 570   continue
cc       print*,' idata / nrestraint ', idata, idx, nrest_tmp

c===================================================================
c if not doing fit (multiple data-set fit), bail out now:
       if (.not.dofit)  then
          call echo('  feffit: not fitting until all data '//
     $         'sets defined')
          return
       end if

c everything below assumes we're really, really doing a fit
c
c read the needed feff arrays
       call fefinp
c

c   set up fit arrays
c   sync variables
c   check # of variables  and # fit points
c   call lmdif1 and fiterr
       write(cmdstr, '(1x,a,i3,a)')  ' feffit fitting ',
     $         nfdats, ' data sets'
       call echo(cmdstr)
       mfit = 0

       do 580 idx = 1, nfdats
          mfit = mfit + (nfit(idx) + nrestraint(idx))* nqwfs(idx)
 580   continue
       mfit = min(mfit, lenfvc)
cc       print*, '  Feffit ', mfit, idx, nfit(idx), nqwfs(idx), nfdats,
cc     $      nrestraint(idx)
cc       if (nrestraint(idx) .ge.1) then
cc          print*, '  Feffit using restraints:',nrestraint(idx)
cc       endif
c===================================================================
c  set up arrays for non-linear fit with lmdif / fitfun
c===================================================================
c
       if (nfit(idata).le.4) then
          call echo('   feffit: too few fit data points: ')
          if (ifft(idata).eq.1) then
             write(cmdstr, 625)  '  Fit R range = [',xolow,
     $            ' : ', xohigh, ']'
          else
             write(cmdstr, 625)  '  Fit k range = [',xolow,
     $            ' : ', xohigh, ']'
          endif
 625      format (a,f8.3,a,f8.3,a)
          call warn(2,cmdstr)
          return
       endif
       if (nvarys.gt.nfit(idata)) then
          call warn(1,' *** feffit: fewer fit data points '//
     $         'than variables! fit may not work.')
       endif

c synchronize the math expressions, set up fit variables
       call iff_sync
       if (toler .le. zero) toler = toldef
       do 700 i =1, nvarys
          varys(i) = scalar(i)
 700   continue
       do 710 i =1, mfit
          fvect(i) = zero
 710   continue
       do 720 i =1, lenwrk
          work(i) = zero
 720   continue
       do 740 i =1, mvarys
          iwork(i)  = 0
 740   continue
c
c  the real fit
       if (nvarys.gt.0)  then
          final = .false.
          itera = 0
          call setsca('&fit_iteration', zero)
          call chrdmp('  fitting ... ')

          call fitfun(mfit, nvarys, varys, fvect, lminfo)

          call lmdif1 (fitfun, mfit, nvarys, varys, fvect,
     $         toler, lminfo, iwork, work, lenwrk)

          call lm_err(lminfo,toler)
cc          if ((lminfo.ne.0).and.(lminfo.ne.4).and.(lminfo.ne.5)) then
          if (lminfo.ne.0) then
             call chrdmp('  estimating uncertainties ... ')
             call fiterr(fitfun, mfit, nvarys, lenfvc, mvarys, fvect,
     $            ftemp, fjac, alpha, jprint, nerstp, varys,
     $            delta, correl, ier, ibadx)
             if (ier.eq.0) then
                call echo('done.')
             else
                call echo('finished with warnings')
                call echo('  error bars not estimated. some '//
     $               'variable(s) may not')
                call echo('  affect the fit. Check these variables:')
                do 880 i = 1, nvarys
                   if (ibadx(i).gt.0) then
                      ilen = istrln(scanam(i))
                      call echo('        '//scanam(i)(:ilen))
                   end if
 880            continue
                call set_status(1)
             endif
          else
             call warn(1,' no uncertainties estimated!')
          end if
       else
          call warn(1,' feffit:  no variables defined.')
       endif
c
c save scalars to Program Variables
       final = .true.
       call synvar
       call fitfun(mfit, nvarys, varys, fvect, lminfo)
       chisqr = sumsqr(fvect, mfit)

c add total number of independent points
c  avoid double counting by inspecting chi(k) names and sum-of-(chi*chi):
c  sure, this can be fooled by adding 1.e-8 to chi(k=0), but....
       xnidp  = xinfo(1)
       do 920 i = 2, nfdats
          uniq_dat  = .true.
          do 910 j = 1, i-1
             if ( (nam_chi(i).eq.nam_chi(j) .or.
     $            (sum2chi(i).eq.sum2chi(j))))
     $            uniq_dat = .false.
 910      continue
          if (uniq_dat)  xnidp = xnidp + xinfo(i)
 920   continue

       chired = chisqr / max(0.1d0, (xnidp - nvarys))
       call setsca('chi_square',  chisqr)
       call setsca('chi_reduced', chired)
       call setsca('r_factor',    rfact_total)
       call setsca('n_idp', xnidp)

       call setsca('kweight', qwfs(1,idata))
       call setsca('kmin',   xkmin)
       call setsca('kmax',   xkmax)
       call setsca('dk1',    dk1)
       call setsca('dk2',    dk2)
       call setsca('rmin',   xrmin)
       call setsca('rmax',   xrmax)

       tmp = nvarys * one
       call setsca('n_varys', tmp)

       do 960 i = 1, nvarys
          delta(i) = sqrt(abs(chired)) * delta(i)
          ilen = istrln(scanam(i))
          messg = 'delta_' // scanam(i)(1:ilen)
          call setsca(messg, delta(i))
 960  continue
c
c  fit with a macro is done, so reset stopping point
c  and previous macro pointer
       if (ifit_mac.gt.0) then
          nmac_stop = 0
          imac      = imac_tmp
       endif
c

c save arrays to Program Variables for each data set
c
       do 3000 idata = 1, nfdats
c          print*, 'FEFFIT ', idata, ' | ' ,
c     $         name1(idata)(1:20), ' | ', nam_chi(idata)(1:20)

c NOTE:
c  thiq(i,data) holds the fit residual, so we'll need to
c  add back the data chi(k) here, and possibly the bkg(k)

c--k
cc        call set_array('resid', name1(idata), thiq(1,idata), nkpts,1)
          do 2200 i = 1, nkpts
             tmparr(i)   = qgrid * (i - 1)
             thiq(i,idata)  = thiq(i,idata)+chiq(i,idata)
 2200     continue
          call set_array('k',   name1(idata), tmparr, nkpts, 1)
          call set_array('chi', name1(idata), thiq(1,idata), nkpts,1)
c
c--background chi(k)
          if (bkgfit(idata)) then
             do 2310 isp = 1, nbkg(idata)
                write(cmdstr, 2325)  'bkg',idata,'_',isp
                xspl(isp) = getsca(cmdstr,0)
 2310        continue
 2325        format (a,i2.2,a,i2.2)
             do 2330 i = 1, nkpts
                qx = qgrid*(i-1)
                tmparr(i) =  bvalue(qknot(1,idata),
     $               xspl,nbkg(idata),korder,qx,0)
                thiq(i, idata) = thiq(i, idata) - tmparr(i)
 2330        continue
             call set_array('kbkg', name1(idata), tmparr, nkpts, 1)
          endif
ccc--chi , which does NOT include the background!
ccc      call set_array('chi', name1(idata), thiq(1,idata), nkpts,1)

c--chi_real
          if (do_re) then
             call set_array('chi_real', name1(idata),
     $            thiqr(1,idata), nkpts, 1)
          end if
c--chi_mag
          if (do_mag) then
             do 2240 i = 1, nkpts
                tmparr(i) = sqrt(
     $               thiqr(i,idata)**2 + thiq(i,idata)**2 )
 2240        continue
             call set_array('chi_mag', name1(idata), tmparr,nkpts,1)
          end if
c--chi_phase
          if (do_pha) then
             do 2280 i = 1, nkpts
                tmparr(i) = atan2( thiq(i,idata), thiqr(i,idata))
                if (i.gt.1)  call pijump(tmparr(i), tmparr(i-1))
 2280        continue
             call set_array('chi_phase', name1(idata), tmparr,nkpts,1)
          end if
c
c      construct r-space data of data and fit
c-data
cc          print*, ' NEAR done: nam_chi = ', nam_chi(idata)(1:40)
cc          print*,  ' name1: ', name1(idata)(1:40)
          j1 = istrln(nam_chi(idata))
          cmdstr  = 'real='// nam_chi(idata)(1:j1)
          if (nam_x(idata) .ne. undef) then
             j0 = istrln(cmdstr)
             j2 = istrln(nam_x(idata))
             cmdstr = cmdstr(:j0)//', k='//nam_x(idata)(:j2)
          endif
          call iff_fft('fftf',cmdstr)
c-fit
          nam_chi(idata) = 'chi'
          call prenam(name1(idata),nam_chi(idata))
          j1 = istrln(nam_chi(idata))
          cmdstr  = 'real = '// nam_chi(idata)(1:j1)
          call iff_fft('fftf',cmdstr)
 3000  continue

c  guess what?   we're done!
       return
       end


*
*     -------------------------------------------------------------
*      N O N R E L A T 4
*     -------------------------------------------------------------
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF MATRIX ELEMENTS        *
*     OF TWO PARTICLE OPERATOR IN CASE :      N'1 = N1 +- 1        *
*                                             N'2 = N2 +- 1        *
*                                             N'3 = N3 -+ 2        *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville            February 1994   *
*                                                                  *
      SUBROUTINE NONRELAT4(IA,IB,IC,ID)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON /OPERAT/ ICOLOM,ISOTOP,IORBORB
      COMMON/MEDEFN/IHSH,NJ(16),LJ(16),NOSH1(16),NOSH2(16),J1QN1(31,3),
     :     J1QN2(31,3),IJFUL(16)
      IF(IHSH.LE.2)RETURN
      IF(IA.EQ.IB) THEN
        IF(ISOTOP.EQ.1) THEN
	  IF(ITTK(LJ(IC),LJ(IA),1).EQ.0)RETURN
	  IF(ITTK(LJ(ID),LJ(IA),1).EQ.0)RETURN
        ENDIF
        CALL NONRELAT41(IC,ID,IA,1,IA,IB,IC,ID)
      ELSEIF(IC.EQ.ID) THEN
        IF(ISOTOP.EQ.1) THEN
	  IF(ITTK(LJ(IA),LJ(IC),1).EQ.0)RETURN
	  IF(ITTK(LJ(IB),LJ(IC),1).EQ.0)RETURN
        ENDIF
        CALL NONRELAT41(IA,IB,IC,2,IA,IB,IC,ID)
      ELSE
	WRITE(6,'(A)')  ' KLAIDA NONRELAT4  '
        STOP
      ENDIF
      RETURN
      END


MODULE nemogcm
   !!======================================================================
   !!                       ***  MODULE nemogcm   ***
   !! Ocean system   : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice)
   !!======================================================================
   !! History :  OPA  ! 1990-10  (C. Levy, G. Madec)  Original code
   !!            7.0  ! 1991-11  (M. Imbard, C. Levy, G. Madec)
   !!            7.1  ! 1993-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
   !!                             P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1
   !!             -   ! 1992-06  (L.Terray)  coupling implementation
   !!             -   ! 1993-11  (M.A. Filiberti) IGLOO sea-ice
   !!            8.0  ! 1996-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
   !!                             P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0
   !!            8.1  ! 1997-06  (M. Imbard, G. Madec)
   !!            8.2  ! 1999-11  (M. Imbard, H. Goosse)  sea-ice model
   !!                 ! 1999-12  (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols)  OPEN-MP
   !!                 ! 2000-07  (J-M Molines, M. Imbard)  Open Boundary Conditions  (CLIPPER)
   !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90: Free form and modules
   !!             -   ! 2004-06  (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces
   !!             -   ! 2004-08  (C. Talandier) New trends organization
   !!             -   ! 2005-06  (C. Ethe) Add the 1D configuration possibility
   !!             -   ! 2005-11  (V. Garnier) Surface pressure gradient organization
   !!             -   ! 2006-03  (L. Debreu, C. Mazauric)  Agrif implementation
   !!             -   ! 2006-04  (G. Madec, R. Benshila)  Step reorganization
   !!             -   ! 2007-07  (J. Chanut, A. Sellar) Unstructured open boundaries (BDY)
   !!            3.2  ! 2009-08  (S. Masson)  open/write in the listing file in mpp
   !!            3.3  ! 2010-05  (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
   !!             -   ! 2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase
   !!            3.3.1! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation
   !!             -   ! 2011-11  (C. Harris) decomposition changes for running with CICE
   !!            3.6  ! 2012-05  (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening
   !!             -   ! 2014-12  (G. Madec) remove KPP scheme and cross-land advection (cla)
   !!            4.0  ! 2016-10  (G. Madec, S. Flavoni)  domain configuration / user defined interface
   !!----------------------------------------------------------------------

   !!----------------------------------------------------------------------
   !!   nemo_gcm      : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
   !!   nemo_init     : initialization of the NEMO system
   !!   nemo_ctl      : initialisation of the contol print
   !!   nemo_closefile: close remaining open files
   !!   nemo_alloc    : dynamical allocation
   !!----------------------------------------------------------------------
   USE step_oce       ! module used in the ocean time stepping module (step.F90)
   USE phycst         ! physical constant                  (par_cst routine)
   USE domain         ! domain initialization   (dom_init & dom_cfg routines)
   USE closea         ! treatment of closed seas (for ln_closea)
   USE usrdef_nam     ! user defined configuration
   USE tideini        ! tidal components initialization   (tide_ini routine)
   USE bdy_oce,  ONLY : ln_bdy
   USE bdyini         ! open boundary cond. setting       (bdy_init routine)
   USE istate         ! initial state setting          (istate_init routine)
   USE ldfdyn         ! lateral viscosity setting      (ldfdyn_init routine)
   USE ldftra         ! lateral diffusivity setting    (ldftra_init routine)
   USE trdini         ! dyn/tra trends initialization     (trd_init routine)
   USE asminc         ! assimilation increments
   USE asmbkg         ! writing out state trajectory
   USE diaptr         ! poleward transports           (dia_ptr_init routine)
   USE diadct         ! sections transports           (dia_dct_init routine)
   USE diaobs         ! Observation diagnostics       (dia_obs_init routine)
   USE diacfl         ! CFL diagnostics               (dia_cfl_init routine)
   USE step           ! NEMO time-stepping                 (stp     routine)
   USE icbini         ! handle bergs, initialisation
   USE icbstp         ! handle bergs, calving, themodynamics and transport
   USE cpl_oasis3     ! OASIS3 coupling
   USE c1d            ! 1D configuration
   USE step_c1d       ! Time stepping loop for the 1D configuration
   USE dyndmp         ! Momentum damping
   USE stopar         ! Stochastic param.: ???
   USE stopts         ! Stochastic param.: ???
   USE diurnal_bulk   ! diurnal bulk SST
   USE step_diu       ! diurnal bulk SST timestepping (called from here if run offline)
   USE crsini         ! initialise grid coarsening utility
   USE diatmb         ! Top,middle,bottom output
   USE dia25h         ! 25h mean output
   USE sbc_oce , ONLY : lk_oasis
   USE wet_dry        ! Wetting and drying setting   (wad_init routine)

   !
   USE lib_mpp        ! distributed memory computing
   USE mppini         ! shared/distributed memory setting (mpp_init routine)
   USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop   ! Setup of north fold exchanges
   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)

   USE xios           ! xIOserver

   IMPLICIT NONE
   PRIVATE

   PUBLIC   nemo_gcm    ! called by model.F90
   PUBLIC   nemo_init   ! needed by AGRIF
   PUBLIC   nemo_alloc  ! needed by TAM

   CHARACTER(lc) ::   cform_aaa="( /, 'AAAAAAAA', / ) "     ! flag for output listing

   !!----------------------------------------------------------------------
   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
   !! $Id: nemogcm.F90 10068 2018-08-28 14:09:04Z nicolasmartin $
   !! Software governed by the CeCILL license (see ./LICENSE)
   !!----------------------------------------------------------------------
CONTAINS

   SUBROUTINE nemo_gcm
      !!----------------------------------------------------------------------
      !!                     ***  ROUTINE nemo_gcm  ***
      !!
      !! ** Purpose :   NEMO solves the primitive equations on an orthogonal
      !!              curvilinear mesh on the sphere.
      !!
      !! ** Method  : - model general initialization
      !!              - launch the time-stepping (stp routine)
      !!              - finalize the run by closing files and communications
      !!
      !! References : Madec, Delecluse, Imbard, and Levy, 1997:  internal report, IPSL.
      !!              Madec, 2008, internal report, IPSL.
      !!----------------------------------------------------------------------
      INTEGER ::   istp   ! time step index
      !!----------------------------------------------------------------------
      !

      !                            !-----------------------!
      CALL nemo_init               !==  Initialisations  ==!
      !                            !-----------------------!
      ! check that all process are still there... If some process have an error,
      ! they will never enter in step and other processes will wait until the end of the cpu time!
      IF( lk_mpp )   CALL mpp_max( nstop )

      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA

      !                            !-----------------------!
      !                            !==   time stepping   ==!
      !                            !-----------------------!
      istp = nit000
      !
      !
      !
      IF( .NOT.ln_diurnal_only ) THEN                 !==  Standard time-stepping  ==!
         !
         DO WHILE( istp <= nitend .AND. nstop == 0 )
            CALL stp        ( istp )
            istp = istp + 1
         END DO
         !
      ELSE                                            !==  diurnal SST time-steeping only  ==!
         !
         DO WHILE( istp <= nitend .AND. nstop == 0 )
            CALL stp_diurnal( istp )   ! time step only the diurnal SST
            istp = istp + 1
         END DO
         !
      ENDIF
      !
      !
      !
      IF( ln_diaobs   )   CALL dia_obs_wri
      !
      IF( ln_icebergs )   CALL icb_end( nitend )

      !                            !------------------------!
      !                            !==  finalize the run  ==!
      !                            !------------------------!
      IF(lwp) WRITE(numout,cform_aaa)        ! Flag AAAAAAA
      !
      IF( nstop /= 0 .AND. lwp ) THEN        ! error print
         WRITE(numout,cform_err)
         WRITE(numout,*) '   ==>>>   nemo_gcm: a total of ', nstop, ' errors have been found'
         WRITE(numout,*)
      ENDIF
      !
      IF( ln_timing )   CALL timing_finalize
      !
      CALL nemo_closefile
      !
                                    CALL xios_finalize  ! end mpp communications with xios
      IF( lk_oasis     )            CALL cpl_finalize   ! end coupling and mpp communications with OASIS
      !
   END SUBROUTINE nemo_gcm

   SUBROUTINE nemo_init
      !!----------------------------------------------------------------------
      !!                     ***  ROUTINE nemo_init  ***
      !!
      !! ** Purpose :   initialization of the NEMO GCM
      !!----------------------------------------------------------------------
      INTEGER  ::   ji                 ! dummy loop indices
      INTEGER  ::   ios, ilocal_comm   ! local integers
      CHARACTER(len=120), DIMENSION(60) ::   cltxt, cltxt2, clnam
      !!
      NAMELIST/namctl/ ln_ctl   , nn_print, nn_ictls, nn_ictle,   &
         &             nn_isplt , nn_jsplt, nn_jctls, nn_jctle,   &
         &             ln_timing, ln_diacfl
      NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr
      !!----------------------------------------------------------------------
      !
      cltxt  = ''
      cltxt2 = ''
      clnam  = ''
      cxios_context = 'nemo'
      !
      !                             ! Open reference namelist and configuration namelist files
      CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
      CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
      !
      REWIND( numnam_ref )              ! Namelist namctl in reference namelist
      READ  ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
      REWIND( numnam_cfg )              ! Namelist namctl in confguration namelist
      READ  ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
      !
      REWIND( numnam_ref )              ! Namelist namcfg in reference namelist
      READ  ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
      REWIND( numnam_cfg )              ! Namelist namcfg in confguration namelist
      READ  ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )

      !                             !--------------------------!
      !                             !  Set global domain size  !   (control print return in cltxt2)
      !                             !--------------------------!
      IF( ln_read_cfg ) THEN              ! Read sizes in domain configuration file
         CALL domain_cfg ( cltxt2,        cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
         !
      ELSE                                ! user-defined namelist
         CALL usr_def_nam( cltxt2, clnam, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
      ENDIF
      !
      !
      !                             !--------------------------------------------!
      !                             !  set communicator & select the local node  !
      !                             !  NB: mynode also opens output.namelist.dyn !
      !                             !      on unit number numond on first proc   !
      !                             !--------------------------------------------!
      IF( Agrif_Root() ) THEN
         IF( lk_oasis ) THEN
            CALL cpl_init( "oceanx", ilocal_comm )                               ! nemo local communicator given by oasis
            CALL xios_initialize( "not used"       ,local_comm= ilocal_comm )    ! send nemo communicator to xios
         ELSE
            CALL xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm )    ! nemo local communicator given by xios
         ENDIF
      ENDIF
      ! Nodes selection (control print return in cltxt)
      narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )

      narea = narea + 1                                     ! mynode return the rank of proc (0 --> jpnij -1 )

      lwm = (narea == 1)                                    ! control of output namelists
      lwp = (narea == 1) .OR. ln_ctl                        ! control of all listing output print

      IF(lwm) THEN               ! write merged namelists from earlier to output namelist
         !                       ! now that the file has been opened in call to mynode.
         !                       ! NB: nammpp has already been written in mynode (if lk_mpp_mpi)
         WRITE( numond, namctl )
         WRITE( numond, namcfg )
         IF( .NOT.ln_read_cfg ) THEN
            DO ji = 1, SIZE(clnam)
               IF( TRIM(clnam(ji)) /= '' )   WRITE(numond, * ) clnam(ji)     ! namusr_def print
            END DO
         ENDIF
      ENDIF

      IF(lwp) THEN                            ! open listing units
         !
         CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
         !
         WRITE(numout,*)
         WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
         WRITE(numout,*) '                       NEMO team'
         WRITE(numout,*) '            Ocean General Circulation Model'
         WRITE(numout,*) '                NEMO version 4.0  (2017) '
         WRITE(numout,*)
         WRITE(numout,*)
         DO ji = 1, SIZE(cltxt)
            IF( TRIM(cltxt (ji)) /= '' )   WRITE(numout,*) cltxt(ji)    ! control print of mynode
         END DO
         WRITE(numout,*)
         WRITE(numout,*)
         DO ji = 1, SIZE(cltxt2)
            IF( TRIM(cltxt2(ji)) /= '' )   WRITE(numout,*) cltxt2(ji)   ! control print of domain size
         END DO
         !
         WRITE(numout,cform_aaa)                                        ! Flag AAAAAAA
         !
      ENDIF
      !                                      ! Domain decomposition
      CALL mpp_init                          ! MPP

      ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
      CALL nemo_alloc()

      !                             !-------------------------------!
      !                             !  NEMO general initialization  !
      !                             !-------------------------------!

      CALL nemo_ctl                          ! Control prints
      !
      !                                      ! General initialization
      IF( ln_timing    )   CALL timing_init     ! timing
      IF( ln_timing    )   CALL timing_start( 'nemo_init')
      !
                           CALL     phy_cst         ! Physical constants
                           CALL     eos_init        ! Equation of state
      IF( lk_c1d       )   CALL     c1d_init        ! 1D column configuration
                           CALL     wad_init        ! Wetting and drying options
                           CALL     dom_init("OPA") ! Domain
      IF( ln_crs       )   CALL     crs_init        ! coarsened grid: domain initialization
      IF( ln_ctl       )   CALL prt_ctl_init        ! Print control

      CALL diurnal_sst_bulk_init                ! diurnal sst
      IF( ln_diurnal   )   CALL diurnal_sst_coolskin_init   ! cool skin
      !
      IF( ln_diurnal_only ) THEN                   ! diurnal only: a subset of the initialisation routines
         CALL  istate_init                            ! ocean initial state (Dynamics and tracers)
         CALL     sbc_init                            ! Forcings : surface module
         CALL tra_qsr_init                            ! penetrative solar radiation qsr
         IF( ln_diaobs ) THEN                         ! Observation & model comparison
            CALL dia_obs_init                            ! Initialize observational data
            CALL dia_obs( nit000 - 1 )                   ! Observation operator for restart
         ENDIF
         IF( lk_asminc )   CALL asm_inc_init          ! Assimilation increments
         !
         RETURN                                       ! end of initialization
      ENDIF

                           CALL  istate_init    ! ocean initial state (Dynamics and tracers)

      !                                      ! external forcing
                           CALL    tide_init    ! tidal harmonics
                           CALL     sbc_init    ! surface boundary conditions (including sea-ice)
                           CALL     bdy_init    ! Open boundaries initialisation

      !                                      ! Ocean physics
                           CALL zdf_phy_init    ! Vertical physics

      !                                         ! Lateral physics
                           CALL ldf_tra_init      ! Lateral ocean tracer physics
                           CALL ldf_eiv_init      ! eddy induced velocity param.
                           CALL ldf_dyn_init      ! Lateral ocean momentum physics

      !                                      ! Active tracers
      IF( ln_traqsr    )   CALL tra_qsr_init      ! penetrative solar radiation qsr
                           CALL tra_bbc_init      ! bottom heat flux
      IF( ln_trabbl    )   CALL tra_bbl_init      ! advective (and/or diffusive) bottom boundary layer scheme
                           CALL tra_dmp_init      ! internal tracer damping
                           CALL tra_adv_init      ! horizontal & vertical advection
                           CALL tra_ldf_init      ! lateral mixing

      !                                      ! Dynamics
      IF( lk_c1d       )   CALL dyn_dmp_init      ! internal momentum damping
                           CALL dyn_adv_init      ! advection (vector or flux form)
                           CALL dyn_vor_init      ! vorticity term including Coriolis
                           CALL dyn_ldf_init      ! lateral mixing
                           CALL dyn_hpg_init      ! horizontal gradient of Hydrostatic pressure
                           CALL dyn_spg_init      ! surface pressure gradient

      IF( l_ldfslp     )   CALL ldf_slp_init    ! slope of lateral mixing

      !                                      ! Icebergs
                           CALL icb_init( rdt, nit000)   ! initialise icebergs instance

      !                                      ! Misc. options
                           CALL sto_par_init    ! Stochastic parametrization
      IF( ln_sto_eos   )   CALL sto_pts_init    ! RRandom T/S fluctuations

      !                                      ! Diagnostics
      IF( lk_floats    )   CALL     flo_init    ! drifting Floats
      IF( ln_diacfl    )   CALL dia_cfl_init    ! Initialise CFL diagnostics
                           CALL dia_ptr_init    ! Poleward TRansports initialization
      IF( lk_diadct    )   CALL dia_dct_init    ! Sections tranports
                           CALL dia_hsb_init    ! heat content, salt content and volume budgets
                           CALL     trd_init    ! Mixed-layer/Vorticity/Integral constraints trends
                           CALL dia_obs_init    ! Initialize observational data
                           CALL dia_tmb_init    ! TMB outputs
                           CALL dia_25h_init    ! 25h mean  outputs
      IF( ln_diaobs    )   CALL dia_obs( nit000-1 )   ! Observation operator for restart

      !                                      ! Assimilation increments
      IF( lk_asminc    )   CALL asm_inc_init    ! Initialize assimilation increments
      !
      IF(lwp) WRITE(numout,cform_aaa)           ! Flag AAAAAAA
      !
      IF( ln_timing    )   CALL timing_stop( 'nemo_init')
      !
   END SUBROUTINE nemo_init

   SUBROUTINE nemo_ctl
      !!----------------------------------------------------------------------
      !!                     ***  ROUTINE nemo_ctl  ***
      !!
      !! ** Purpose :   control print setting
      !!
      !! ** Method  : - print namctl information and check some consistencies
      !!----------------------------------------------------------------------
      !
      IF(lwp) THEN                  ! control print
         WRITE(numout,*)
         WRITE(numout,*) 'nemo_ctl: Control prints'
         WRITE(numout,*) '~~~~~~~~'
         WRITE(numout,*) '   Namelist namctl'
         WRITE(numout,*) '      run control (for debugging)     ln_ctl     = ', ln_ctl
         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print
         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
         WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
         WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
         WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
         WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
         WRITE(numout,*) '      timing by routine               ln_timing  = ', ln_timing
         WRITE(numout,*) '      CFL diagnostics                 ln_diacfl  = ', ln_diacfl
      ENDIF
      !
      nprint    = nn_print          ! convert DOCTOR namelist names into OLD names
      nictls    = nn_ictls
      nictle    = nn_ictle
      njctls    = nn_jctls
      njctle    = nn_jctle
      isplt     = nn_isplt
      jsplt     = nn_jsplt

      IF(lwp) THEN                  ! control print
         WRITE(numout,*)
         WRITE(numout,*) '   Namelist namcfg'
         WRITE(numout,*) '      read domain configuration file                ln_read_cfg      = ', ln_read_cfg
         WRITE(numout,*) '         filename to be read                           cn_domcfg     = ', TRIM(cn_domcfg)
         WRITE(numout,*) '         keep closed seas in the domain (if exist)     ln_closea     = ', ln_closea
         WRITE(numout,*) '      create a configuration definition file        ln_write_cfg     = ', ln_write_cfg
         WRITE(numout,*) '         filename to be written                        cn_domcfg_out = ', TRIM(cn_domcfg_out)
         WRITE(numout,*) '      use file attribute if exists as i/p j-start   ln_use_jattr     = ', ln_use_jattr
      ENDIF
      IF( .NOT.ln_read_cfg )   ln_closea = .false.   ! dealing possible only with a domcfg file
      !
      !                             ! Parameter control
      !
      IF( ln_ctl ) THEN                 ! sub-domain area indices for the control prints
         IF( lk_mpp .AND. jpnij > 1 ) THEN
            isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real split domain
         ELSE
            IF( isplt == 1 .AND. jsplt == 1  ) THEN
               CALL ctl_warn( ' - isplt & jsplt are equal to 1',   &
                  &           ' - the print control will be done over the whole domain' )
            ENDIF
            ijsplt = isplt * jsplt            ! total number of processors ijsplt
         ENDIF
         IF(lwp) WRITE(numout,*)'          - The total number of processors over which the'
         IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt
         !
         !                              ! indices used for the SUM control
         IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area
            lsp_area = .FALSE.
         ELSE                                             ! print control done over a specific  area
            lsp_area = .TRUE.
            IF( nictls < 1 .OR. nictls > jpiglo )   THEN
               CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
               nictls = 1
            ENDIF
            IF( nictle < 1 .OR. nictle > jpiglo )   THEN
               CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
               nictle = jpiglo
            ENDIF
            IF( njctls < 1 .OR. njctls > jpjglo )   THEN
               CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
               njctls = 1
            ENDIF
            IF( njctle < 1 .OR. njctle > jpjglo )   THEN
               CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
               njctle = jpjglo
            ENDIF
         ENDIF
      ENDIF
      !
      IF( 1._wp /= SIGN(1._wp,-0._wp)  )   CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.',  &
         &                                                'Compile with key_nosignedzero enabled' )
      !
      !
   END SUBROUTINE nemo_ctl

   SUBROUTINE nemo_closefile
      !!----------------------------------------------------------------------
      !!                     ***  ROUTINE nemo_closefile  ***
      !!
      !! ** Purpose :   Close the files
      !!----------------------------------------------------------------------
      !
      IF( lk_mpp )   CALL mppsync
      !
      CALL iom_close                                 ! close all input/output files managed by iom_*
      !
      IF( numstp          /= -1 )   CLOSE( numstp          )   ! time-step file
      IF( numrun          /= -1 )   CLOSE( numrun          )   ! run statistics file
      IF( numnam_ref      /= -1 )   CLOSE( numnam_ref      )   ! oce reference namelist
      IF( numnam_cfg      /= -1 )   CLOSE( numnam_cfg      )   ! oce configuration namelist
      IF( lwm.AND.numond  /= -1 )   CLOSE( numond          )   ! oce output namelist
      IF( numnam_ice_ref  /= -1 )   CLOSE( numnam_ice_ref  )   ! ice reference namelist
      IF( numnam_ice_cfg  /= -1 )   CLOSE( numnam_ice_cfg  )   ! ice configuration namelist
      IF( lwm.AND.numoni  /= -1 )   CLOSE( numoni          )   ! ice output namelist
      IF( numevo_ice      /= -1 )   CLOSE( numevo_ice      )   ! ice variables (temp. evolution)
      IF( numout          /=  6 )   CLOSE( numout          )   ! standard model output file
      IF( numdct_vol      /= -1 )   CLOSE( numdct_vol      )   ! volume transports
      IF( numdct_heat     /= -1 )   CLOSE( numdct_heat     )   ! heat transports
      IF( numdct_salt     /= -1 )   CLOSE( numdct_salt     )   ! salt transports
      !
      numout = 6                                     ! redefine numout in case it is used after this point...
      !
   END SUBROUTINE nemo_closefile

   SUBROUTINE nemo_alloc
      !!----------------------------------------------------------------------
      !!                     ***  ROUTINE nemo_alloc  ***
      !!
      !! ** Purpose :   Allocate all the dynamic arrays of the OPA modules
      !!
      !! ** Method  :
      !!----------------------------------------------------------------------
      USE diawri    , ONLY : dia_wri_alloc
      USE dom_oce   , ONLY : dom_oce_alloc
      USE trc_oce   , ONLY : trc_oce_alloc
      USE bdy_oce   , ONLY : bdy_oce_alloc
      !
      INTEGER :: ierr
      !!----------------------------------------------------------------------
      !
      ierr =        oce_alloc    ()    ! ocean
      ierr = ierr + dia_wri_alloc()
      ierr = ierr + dom_oce_alloc()    ! ocean domain
      ierr = ierr + zdf_oce_alloc()    ! ocean vertical physics
      ierr = ierr + trc_oce_alloc()    ! shared TRC / TRA arrays
      ierr = ierr + bdy_oce_alloc()    ! bdy masks (incl. initialization)
      !
      !
      IF( lk_mpp    )   CALL mpp_sum( ierr )
      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' )
      !
   END SUBROUTINE nemo_alloc

   !!======================================================================
END MODULE nemogcm