      SUBROUTINE READZ
C
        IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 J2,J3,J4,J22
      INTEGER*4 DDPLY
C
      COMMON/CCMBNZ/ CMRK(10),Z01(4),Z02(4),Z03(4),Z04(4),Z11(12),
     .               Z12(12),Z13(12),Z14(12),Z15(12),Z16(12),Z21(36),
     .               Z22(36),Z23(36),Z24(36),Z25(36),Z26(36),Z27(36),
     .               Z28(36),Z31(108),Z32(108),Z33(108),Z34(108),
     .               Z35(108),Z41(324),Z42(324),Z43(324),ZK21(18),
     .               ZK22(18),ZK23(18),ZK31(54),ZK32(54),ZK33(54),
     .               ZK34(54),ZK35(54),ZK36(54),ZK41(162),ZK42(162),
     .               ZK43(162),ZK44(162),ZK45(162),ZK46(162),ZK47(162),
     .               ZK48(162),ZS01(2),ZS02(2),ZS11(6),ZS12(6),ZS13(6),
     .               ZS21(18),ZS22(18),ZS23(18),ZS24(18),ZS31(54),
     .               ZS32(54),ZS41(162),ZT21(108),ZT22(108),STAO(18),
     .               STA1(18),STA2(18),STBO(18),STB1(18),STB2(18),
     .               Z2S01(2),Z2S12(6),Z2S23(18)
C
      COMMON/CNBODY/ J2,J3,J4,J22,ZJ20,ZMU,WWO,FLAT,AEARTH
C
      COMMON/CFINDX/ AX2CHK,TCHECK,LCHECK
C
      COMMON/CODPLY/ STANG,ANGTOL
C
      COMMON/DATOUT/ IDATA,MLAST
C
      COMMON/DEBUG1/ IAFM(5)
C
      COMMON/DEBUG2/ IOUT,JOUT,KLUGE
C
      COMMON/DEBUG3/ ISWTCH
C
      COMMON/DEPLOY/ DDPLY,MDPLY
C
      COMMON/HAMOUT/ HAMILT,IHAMLT
C
      COMMON/IMAIN1/ IDATE,LSAVE,INOPT,IPLOT,NUMEQS,IPLTPE,IORB,ITAPE
C
      COMMON/IODPLY/ ISDPLY,IRAXIS,ISAXIS,NCROSS,NPRINT
C
      COMMON/RSUNCL/ WE,TVER,ECLPTC
C
      COMMON/VECTRS/ XSAT(3),XSATDT(3),AD(3)
C
      COMMON/ XIN4 / UP(150),DN(150),CONSA,COMEG,AOOP,AOOPV,AOOP1,AOOPV1
     .              ,AIP,AIPV,AIP1,AIPV1,DOOP,DOOPV,DOOP1,DOOPV1,DIP,
     .               DIPV,DIP1,DIPV1,DUC,DUC1,DUCD,DUCD1
C
      COMMON/ZSPINR/ DTZMA,PZDT,CMZO,ISPIN3,JSPIN
C
C
C                       CALL SETUP FOR LABELED COMMON CCMBNZ
C
       CALL SETUP(8HZ01     ,8,Z01,4)
       CALL SETUP(8HZ02     ,8,Z02,4)
       CALL SETUP(8HZ03     ,8,Z03,4)
       CALL SETUP(8HZ04     ,8,Z04,4)
       CALL SETUP(8HZ11     ,8,Z11,12)
       CALL SETUP(8HZ12     ,8,Z12,12)
       CALL SETUP(8HZ13     ,8,Z13,12)
       CALL SETUP(8HZ14     ,8,Z14,12)
       CALL SETUP(8HZ15     ,8,Z15,12)
       CALL SETUP(8HZ16     ,8,Z16,12)
       CALL SETUP(8HZ21     ,8,Z21,36)
       CALL SETUP(8HZ22     ,8,Z22,36)
       CALL SETUP(8HZ23     ,8,Z23,36)
       CALL SETUP(8HZ24     ,8,Z24,36)
       CALL SETUP(8HZ25     ,8,Z25,36)
       CALL SETUP(8HZ26     ,8,Z26,36)
       CALL SETUP(8HZ27     ,8,Z27,36)
       CALL SETUP(8HZ28     ,8,Z28,36)
       CALL SETUP(8HZ31     ,8,Z31,108)
       CALL SETUP(8HZ32     ,8,Z32,108)
       CALL SETUP(8HZ33     ,8,Z33,108)
       CALL SETUP(8HZ34     ,8,Z34,108)
       CALL SETUP(8HZ35     ,8,Z35,108)
       CALL SETUP(8HZ41     ,8,Z41,324)
       CALL SETUP(8HZ42     ,8,Z42,324)
       CALL SETUP(8HZ43     ,8,Z43,324)
       CALL SETUP(8HZK21    ,8,ZK21,18)
       CALL SETUP(8HZK22    ,8,ZK22,18)
       CALL SETUP(8HZK23    ,8,ZK23,18)
       CALL SETUP(8HZK31    ,8,ZK31,54)
       CALL SETUP(8HZK32    ,8,ZK32,54)
       CALL SETUP(8HZK33    ,8,ZK33,54)
       CALL SETUP(8HZK34    ,8,ZK34,54)
       CALL SETUP(8HZK35    ,8,ZK35,54)
       CALL SETUP(8HZK36    ,8,ZK36,54)
       CALL SETUP(8HZK41    ,8,ZK41,162)
       CALL SETUP(8HZK42    ,8,ZK42,162)
       CALL SETUP(8HZK43    ,8,ZK43,162)
       CALL SETUP(8HZK44    ,8,ZK44,162)
       CALL SETUP(8HZK45    ,8,ZK45,162)
       CALL SETUP(8HZK46    ,8,ZK46,162)
       CALL SETUP(8HZK47    ,8,ZK47,162)
       CALL SETUP(8HZK48    ,8,ZK48,162)
       CALL SETUP(8HZS01    ,8,ZS01,2)
       CALL SETUP(8HZS02    ,8,ZS02,2)
       CALL SETUP(8HZS11    ,8,ZS11,6)
       CALL SETUP(8HZS12    ,8,ZS12,6)
       CALL SETUP(8HZS13    ,8,ZS13,6)
       CALL SETUP(8HZS21    ,8,ZS21,18)
       CALL SETUP(8HZS22    ,8,ZS22,18)
       CALL SETUP(8HZS23    ,8,ZS23,18)
       CALL SETUP(8HZS24    ,8,ZS24,18)
       CALL SETUP(8HZS31    ,8,ZS31,54)
       CALL SETUP(8HZS32    ,8,ZS32,54)
       CALL SETUP(8HZS41    ,8,ZS41,162)
       CALL SETUP(8HZT21    ,8,ZT21,108)
       CALL SETUP(8HZT22    ,8,ZT22,108)
       CALL SETUP(8HSTAO    ,8,STAO,18)
       CALL SETUP(8HSTA1    ,8,STA1,18)
       CALL SETUP(8HSTA2    ,8,STA2,18)
       CALL SETUP(8HSTBO    ,8,STBO,18)
       CALL SETUP(8HSTB1    ,8,STB1,18)
       CALL SETUP(8HSTB2    ,8,STB2,18)
       CALL SETUP(8HZ2S01   ,8,Z2S01,2)
       CALL SETUP(8HZ2S12   ,8,Z2S12,6)
       CALL SETUP(8HZ2S23   ,8,Z2S23,18)
C
C                       CALL SETUP FOR LABELED COMMON CNBODY
      CALL SETUP('J2      ',8,J2)
      CALL SETUP('J3      ',8,J3)
      CALL SETUP('J4      ',8,J4)
      CALL SETUP('J22     ',8,J22)
      CALL SETUP('ZJ20    ',8,ZJ20)
      CALL SETUP('ZMU     ',8,ZMU)
      CALL SETUP('WWO     ',8,WWO)
      CALL SETUP('FLAT    ',8,FLAT)
      CALL SETUP('AEARTH  ',8,AEARTH)
C
C                       CALL SETUP FOR LABELED COMMON CFINDX
C
      CALL SETUP('AX2CHK  ',8,AX2CHK)
      CALL SETUP('TCHECK  ',8,TCHECK)
      CALL SETUP('LCHECK  ',4,LCHECK)
C
C                       CALL SETUP FOR LABELED COMMON CODPLY
C
      CALL SETUP(8HSTANG   ,8,STANG)
      CALL SETUP(8HANGTOL  ,8,ANGTOL)
C
C                       CALL SETUP FOR LABELED COMMON DATOUT
C
      CALL SETUP ('IDATA   ',4,IDATA)
      CALL SETUP ('MLAST   ',4,MLAST)
C
C                       CALL SETUP FOR LABELED COMMON DEBUG1
C
      CALL SETUP(8HIAFM    ,4,IAFM,5)
C
C
C                       CALL SETUP FOR LABELED COMMON DEBUG2
C
      CALL SETUP('IOUT    ',4,IOUT)
      CALL SETUP('KLUGE   ',4,KLUGE)
C
C                       CALL SETUP FOR LABELED COMMON DEBUG3
C
      CALL SETUP(8HISWTCH  ,4,ISWTCH)
C
C                       CALL SETUP FOR LABELED COMMON DEPLOY
C
      CALL SETUP(8HDDPLY   ,4,DDPLY)
      CALL SETUP(8HMDPLY   ,4,MDPLY)
C
C                       CALL SETUP FOR LABELED COMMON HAMOUT
C
      CALL SETUP(8HIHAMLT  ,4,IHAMLT)
C
C                       CALL SETUP FOR LABELED COMMON IMAIN1
C
      CALL SETUP('IORB    ',4,IORB)
      CALL SETUP('ITAPE    ',4,ITAPE)
C
C                       CALL SETUP FOR LABELED COMMON IODPLY
C
      CALL SETUP(8HISDPLY  ,4,ISDPLY)
      CALL SETUP(8HIRAXIS  ,4,IRAXIS)
      CALL SETUP(8HISAXIS  ,4,ISAXIS)
      CALL SETUP(8HNCROSS  ,4,NCROSS)
      CALL SETUP(8HNPRINT  ,4,NPRINT)
C
C                       CALL SETUP FOR LABELED COMMON RSUNCL
C
      CALL SETUP('WE      ',8,WE)
      CALL SETUP('TVER    ',8,TVER)
      CALL SETUP('ECLPTC  ',8,ECLPTC)
C
C                       CALL SETUP FOR LABELED COMMON VECTRS
C
      CALL SETUP('XSAT    ',8,XSAT,3)
      CALL SETUP('XSATDT  ',8,XSATDT,3)
C
C                       CALL SETUP FOR LABELED COMMON XIN4
      CALL SETUP(8HUP      ,8,UP,150)
      CALL SETUP(8HDN      ,8,DN,150)
      CALL SETUP(8HCONSA   ,8,CONSA)
      CALL SETUP(8HCOMEG   ,8,COMEG)
      CALL SETUP(8HAOOP    ,8,AOOP)
      CALL SETUP(8HAOOPV   ,8,AOOPV)
      CALL SETUP(8HAOOP1   ,8,AOOP1)
      CALL SETUP(8HAOOPV1  ,8,AOOPV1)
      CALL SETUP(8HAIP     ,8,AIP)
      CALL SETUP(8HAIPV    ,8,AIPV)
      CALL SETUP(8HAIP1    ,8,AIP1)
      CALL SETUP(8HAIPV1   ,8,AIPV1)
      CALL SETUP(8HDOOP    ,8,DOOP)
      CALL SETUP(8HDOOPV   ,8,DOOPV)
      CALL SETUP(8HDOOP1   ,8,DOOP1)
      CALL SETUP(8HDOOPV1  ,8,DOOPV1)
      CALL SETUP(8HDIP     ,8,DIP)
      CALL SETUP(8HDIPV    ,8,DIPV)
      CALL SETUP(8HDIP1    ,8,DIP1)
      CALL SETUP(8HDIPV1   ,8,DIPV1)
      CALL SETUP(8HDUC     ,8,DUC)
      CALL SETUP(8HDUC1    ,8,DUC1)
      CALL SETUP(8HDUCD    ,8,DUCD)
      CALL SETUP(8HDUCD1   ,8,DUCD1)
C
C                       CALL SETUP FOR LABELED COMMON ZSPINR
C
      CALL SETUP(8HDTZMA   ,8,DTZMA)
      CALL SETUP(8HPZDT    ,8,PZDT)
      CALL SETUP(8HCMZO    ,8,CMZO)
      CALL SETUP(8HISPIN3  ,4,ISPIN3)
C
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     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, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine applybounp(nodeboun,ndirboun,nboun,xbounact,
     &     ithermal,nk,iponoel,inoel,vold,vcontu,t1act,isolidsurf,
     &     nsolidsurf,xsolidsurf,nfreestream,ifreestream,turbulent,
     &     vcon,shcon,nshcon,rhcon,nrhcon,ielmat,ntmat_,physcon,v,
     &     ipompc,nodempc,coefmpc,nmpc,inomat,mi)
!
!     applies velocity boundary conditions
!
      implicit none
!
      integer turbulent,
     &     nrhcon(*),mi(*),ielmat(mi(3),*),ntmat_,nodeboun(*),
     &     isolidsurf(*),
     &     ndirboun(*),nshcon(*),nk,i,nboun,node,imat,ithermal(*),
     &     iponoel(*),
     &     inoel(3,*),nsolidsurf,ifreenode,ifreestream(*),nfreestream,k,
     &     index,ipompc(*),nodempc(3,*),nmpc,ist,ndir,inomat(*),ndiri,
     &     nodei
!
      real*8 rhcon(0:1,ntmat_,*),vold(0:mi(2),*),xbounact(*),shcon,
     &     vcontu(2,*),t1act(*),temp,r,dvi,xsolidsurf(*),reflength,
     &     refkin,reftuf,refvel,cp,vcon(0:4,*),physcon(*),v(0:mi(2),*),
     &     coefmpc(*),fixed_pres,size,correction,residu
!
!     inserting the pressure boundary conditions
!
      do i=1,nboun
        if(ndirboun(i).ne.4) cycle
!
        node=nodeboun(i)
        v(4,node)=xbounact(i)-vold(4,node)
      enddo
!
!     inserting the pressure MPC conditions
!
      do i=1,nmpc
        ist=ipompc(i)
        ndir=nodempc(2,ist)
        if(ndir.ne.4) cycle
        node=nodempc(1,ist)
!
!     check whether fluid MPC
!
        imat=inomat(node)
        if(imat.eq.0) cycle
!
        index=nodempc(3,ist)
        residu=0.d0
        if(index.ne.0) then
          do
            nodei=nodempc(1,index)
            ndiri=nodempc(2,index)
!
            residu=residu+coefmpc(index)*
     &           (vold(ndiri,nodei)+v(ndiri,nodei))
            index=nodempc(3,index)
            if(index.eq.0) exit
          enddo
        endif
!
        v(ndir,node)=-residu/coefmpc(ist)-vold(ndir,node)
      enddo
!
      return
      end


!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
! File qMEfuns.f90: modified from qsolveME.f90 by Ding Ma and Michael Saunders
!
! subroutine qsolveME (changed from program, for f2py)
!     contains
!         subroutine qdq
!         subroutine qd
! subroutine funcon
! subroutine funobj
! subroutine matmod (dummy)
!
! Modified code from Ding Ma and Michael Saunders for compatibility with f2py
! and calling from python
!
! Laurence Yang, SBRG, UCSD
!
! How to generate python extension module via f2py, and use from python:
!   0) [prerequisite] make qminos using -fPIC compiler flag.
!      Otherwise, will get error at step 2) about requiring the -fPIC flag

!   1) Generate signature file, qsolveME.pyf:
!      f2py -m qsolveME -h qsolveME.pyf qMEfuns.f90 qmatrixA.f90
!
!   2) Compile with qminos library linked, and generate .so file to import into python:
!      f2py -c qsolveME.pyf qMEfuns.f90 qmatrixA.f90 -L/home/laurence/Software/qminos1114/qminos56/lib -lquadminos
!
!   3) From python:
!      import qsolveME
!      import numpy as np
!      inform = np.array(0)     # gets modified by qsolveme: in/output exit flag
!      mu0 = 0.1
!      x = qsolveME.qsolveme(inform, mu0, probname, M, nnCon, nnJac, neJac, ha,
!      ka, ad, bld, bud, nb, N, ne)
!
! 19 Jul 2015: [LY] first version.
! 20 Jul 2015: [LY] reproduced fortran solution from python--still fort.8 input
! file, though
! 30 Jul 2015: [LY] return inform (exit status) as intent(inout)
! 14 Aug 2015: [LY] qsolveME is now warm-startable with intent(inout) basis
!                   if warm=True
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

! 20 Jul 2015: [LY] modified such that solution is returned to python as double,
!                   rounded from quad.
! 22 Jul 2015: [LY] mu0 is an input argument
!                   Also specified intent(in) and intent(out) for nb and xnd,
!                   so the .pyf file from py2f need not be manually edited
subroutine qsolveME(xnd, inform, nb, mu0d, Probname, m, n, ne, nnCon, nnJac, neJac, &
    ha, ka, ad, bld, bud, hs, warm, &
    nStrOpts, nIntOpts, nRealOpts, stropts, intopts, realopts, intvals, realvalsd)
  ! From qmatrixA, use only: ...
  ! use qmatrixA,  only: maxnnCon, maxnnJac, maxneJac, haa, kaa, aa
  ! 24 Mar 2016: allocatable haa, kaa, aa
  use qmatrixA,  only: haa, kaa, aa

  implicit none

  integer, parameter        :: ip = 4, dp = 8, qp = 16
  ! Pass options directly instead of using specs file
  integer(ip), intent(in)                               :: nStrOpts
  integer(ip), intent(in)                               :: nIntOpts
  integer(ip), intent(in)                               :: nRealOpts
  character(len=72), dimension(nStrOpts), intent(in)    :: stropts
  character(len=55), dimension(nIntOpts), intent(in)    :: intopts
  character(len=55), dimension(nRealOpts),intent(in)    :: realopts
  integer(ip), dimension(nIntOpts), intent(in)          :: intvals
  ! Real options input as real(8) but converted to quad when passing to minos
  real(dp), dimension(nRealOpts), intent(in)            :: realvalsd
  real(qp), dimension(nRealOpts)                        :: realvals

  ! qMINOS common block
  real(16)        :: dparm
  integer         :: iparm
  common    /m2parm/ dparm(30),iparm(30)
  ! 22 Jul 2015: [LY] ensure these params in the right order...
  !              provide these params as arguments instead of reading from file
  integer(ip),  intent(in)  :: nb
  real(dp),     intent(in)  :: mu0d
  character(8), intent(in)  :: Probname
  integer(ip),  intent(in)  :: m, n, ne, nnCon, nnJac, neJac
  integer(ip), dimension(ne),  intent(in)  :: ha
  integer(ip), dimension(n+1),  intent(in)  :: ka
  real(dp), dimension(ne), intent(in)    :: ad
  real(dp), dimension(nb), intent(in)    :: bld, bud
  logical, intent(in)       :: warm

  ! Local variables for MINOS
  integer(ip)               :: INFO, iExit
  !  integer(ip)               :: iSpecs, nnCon, nnJac, neJac, nnObj, nwcore
  integer(ip)               :: iSpecs, nnObj, nwcore
  ! integer(ip)               :: iObj, iPrint, iSumm, inform, nout
  ! 30 Jul 2015: [LY] want to return inform (exit status) to user
  integer(ip)               :: iObj, iPrint, iSumm, nout
  integer(ip),intent(inout) :: inform
  ! integer(ip)               :: m, n, nb, ne, mincor, nInf, nname, nS
  integer(ip)               :: mincor, nInf, nname, nS
  real(qp)                  :: ObjAdd, Obj, sInf
  ! LY: allocatable: at run time, allocate() used to assign memory for storage during execution
  !integer(ip),  allocatable :: hs(:)
  integer(ip),intent(inout) :: hs(nb)
  ! integer(ip),  allocatable :: ha(:), ka(:)

  ! real(qp),     allocatable :: a(:)
  real(qp)                  :: a(ne)
  ! 22 Jul 2015: [LY] no need to allocate dynamically
  ! real(dp),     intent(in)  :: bld(nb), bud(nb)
  real(qp)                  :: bl(nb), bu(nb)
  !real(qp),     allocatable :: xn(:), pi(:), rc(:)
  real(qp),     allocatable :: pi(:), rc(:)

  ! LY: make double version of xn, which will be intent(output) to python
  real(dp),   intent(inout) :: xnd(nb)      ! double-rounded version of xn, which is quad
  real(qp)                  :: xn(nb)       ! quad

  integer(ip),  allocatable :: name1(:), name2(:)
  !character(8)              :: names(5), Probname
  character(8)              :: names(5)
  ! LY: as argument

  integer(ip),  parameter   :: lenz = 100000000 !5000000   ! As big as you like.
  real(qp)                  :: z(lenz)          ! This is the MINOS workspace.

  ! Local variables for the problem
  integer(ip)               :: in, i, j, k, l, nnCon0, nnObj0, nnJac0
  real(qp)                  :: mu0
  real(qp),     parameter   :: zero = 0.0_qp
  !------------------------------------------------------------------
  ! LY: user inputs mu0d as double, convert to quad for qMINOS
  mu0 = real(mu0d, qp)

  ! LY: instead of reading a file, pass model data directly from python
  ! Assign nnCon, nnJac, etc. directly from python
  ! Or make a internal procedure to interface the required variable
  ! assignments clearly to python?

   in     = 8         ! File from ~/matlab/tinyME/dumpME_NLP.m (e.g. tinyME.txt)
                      ! cp tinyME.txt fort.10
   ! open(in, status='old')
   ! read(in,*) Probname! Problem name, up to 8 characters
   ! read(in,*) nnCon   ! No of rows in Jacobian, the matrix [Abar*xbar mu*Abar]
   ! read(in,*) nnJac   ! No of cols in Jacobian
   ! read(in,*) neJac   ! No of nonzeros in Jacobian
   ! read(in,*) m       ! No of rows in A
   ! read(in,*) n       ! No of cols in A
   ! read(in,*) ne      ! No of nonzeros in A

!  if      (nnCon > maxnnCon) then
!     write(*,*) 'maxnnCon in qmatrixA  is smaller than', nnCon
!     stop
!  else if (nnJac > maxnnJac) then
!     write(*,*) 'maxnnJac in qmatrixA  is smaller than', nnJac
!     stop
!  else if (neJac > maxneJac) then
!     write(*,*) 'maxneJac in qmatrixA  is smaller than', neJac
!     stop
!  end if

  ! 24 Mar 2016 [LY]
  ! Allocate A
  write(*,*) 'Allocating haA (neJac):', neJac
  write(*,*) 'Allocating kaA (nnJac+1):', nnJac+1
  write(*,*) 'Allocating aA (neJac): ', neJac
  allocate( haA(neJac), kaA(nnJac+1))
  allocate( aA(neJac))

  ! Allocate A as pointers, row indices, and Aij
  ! allocate( ka(n+1), a(ne), ha(ne) )
  ! read(in,*) ka      ! Pointers for A
  ! read(in,*) ha      ! Row indices
  ! read(in,*) a       ! Aij
  ! 22 Jul 2015: [LY] allocate quad Aij
  ! allocate(a(ne))
  a = real(ad, qp)

  ! nb       = n + m
  nname    = 1

  print*, 'Allocating name1, name2'
  allocate( name1(nname), name2(nname) )

!  print*, 'Allocating pi, rc, xn'
!  allocate( pi(m), rc(nb), xn(nb) )
  print*, 'Allocating pi, rc '
  allocate( pi(m), rc(nb) )

  print *, 'Allocated pi, rc, xn'

  ! 22 Jul 2015: [LY] allocate quad bl, bu. Populate from user-provided dp
  ! allocate( bl(nb), bu(nb) )
  bl = real(bld, qp)
  bu = real(bud, qp)

  ! read(in,*) bl        ! Lower bounds for x and slacks
  ! read(in,*) bu        ! Upper bounds for x and slacks
  ! close(in)

  ! The data (a,bl,bu) just read into Quad arrays was really just Double.
  ! For example, a(1) may now be [a11 a12] in Quad.
  ! Round from Quad to Double [a11] and then back to Quad as [a11 0]

  call qdq(  a, ne )
  call qdq( bl, nb )
  call qdq( bu, nb )

  ! Save the Jacobian part of A in the arrays of module qmatrixA.
  ! (This is the f90 alternative to a common block.)
  ! LY: comments from qminos56/src/mi02lib.f
  ! a(ne)   constraint matrix (Jacobian), stored column-wise
  ! ha(ne)  list of row indices for each nonzero in a(*)
  ! ka(n+1) set of pointers to beginning of each column of the constraint matrix
  !         within a(*) and ha(*). Must have ka(1) = 1 and ka(n+1) = ne+1.

  l = 0
  do j = 1, nnJac
     kaA(j) = l+1
     do k = ka(j), ka(j+1)-1
        i = ha(k)
        if (i > nnCon) exit
        l = l+1
        haA(l) = i
         aA(l) = a(k)
     end do
  end do

  kaA(nnJac+1) = l+1   ! Last pointer

  ! Assign various names.
  ! These are relics from the days of MPS files.
  ! They appear in the MINOS Print file and/or Solution file.

  names(1) = Probname
  names(2) = 'c       '  ! Objective name
  names(3) = 'b       '  ! RHS name
  names(4) = '        '  ! Ranges name (bounds on slacks)
  names(5) = 'bounds  '  ! Bounds name (bounds on variables)

  ! Specify file numbers for MINOS.  (Others may be in the SPECS file.)
  ! 0 means that there should be no file.

!  ispecs = 4   ! The MINOS SPECS   file.
  ispecs = 0   ! The MINOS SPECS   file.
! ispecs2= 5   ! The second SPECS  file (for warm start)
  iprint = 9   ! The MINOS PRINT   file.
  isumm  = 6   ! The MINOS SUMMARY file.
  nout   = 6   ! Local output file (6 = screen).

  ! Now we may open any number of files ourselves
  ! (perhaps to give them sensible names).
  ! For example:

  ! open( iprint, file='TMA_ME.out', status='UNKNOWN')
  ! open( ispecs, file='TMA_ME.spc', status='OLD')

  ! Alternatively, we may let mistart and minoss open them,
  ! using the method selected in subroutine m1open
  ! in the mi10*.f file that was used to build MINOS.
  !
  ! RULE OF THUMB:
  ! MINOS won't open file ispec (for example)
  ! if that unit is already open, or if ispec = 0.
  !------------------------------------------------------------------

  !------------------------------------------------------------------
  ! mistart MUST BE CALLED BEFORE ANY OTHER MINOS ROUTINE.
  !------------------------------------------------------------------
  call mistart( iprint, isumm, ispecs )  ! Initialize MINOS and open
                                         ! the specified files.

  ! call mispec( ispecs, inform )          ! Read the SPECS file
                                         ! (if ispecs > 0).
  !------------------------------------------------------------------
  ! Specify options directly
  ! Options written as one string
  do i=1, nStrOpts
    write(*,*) 'Calling miopt to set option: ', trim(stropts(i))
    call miopt(trim(stropts(i)), iprint, isumm, inform)
  end do

  ! Integer valued options
  do i=1, nIntOpts
    write(*,*) 'Calling miopti to set option ', trim(intopts(i)), ' to ', intvals(i)
    call miopti(trim(intopts(i)), intvals(i), iprint, isumm, inform)
  end do

  ! Real-valued options
  ! Convert double to quad options
  call dq( realvals, realvalsd, nRealOpts )

  do i=1, nRealOpts
    write(*,*) 'Calling mioptr to set option ', trim(realopts(i)), ' to ', realvalsd(i)
    call mioptr(trim(realopts(i)), realvals(i), iprint, isumm, inform)
  end do

  !------------------------------------------------------------------
  if (inform >= 2) then
     write(nout, *) 'Error: ispecs > 0 but no SPECS file found'
     stop
  end if

  !----------------------------------------------------------------------
  ! Solve the problem.
  ! iobj   = 0    means there is no linear objective row in a(*).
  ! objadd = zero means there is no constant to be added to the objective.
  ! nname  = 1    means there are no meaningful names for the
  !               variables and constraints inside name1(*) and name2(*).
  !               MINOS will print default names.
  !----------------------------------------------------------------------
  ! [LY] 22 Jul 2015: provide mu0 as argument
  ! mu0 = dparm(20)
  write(*, "(/ ' mu0d =', f4.1)") mu0d
  write(*, "(/ ' mu0  =', f4.1)") mu0

  write(iprint, "(/ ' mu0  =', f4.1)") mu0
  write(isumm , "(/ ' mu0  =', f4.1)") mu0

  !hs(1:nb) = 0
  !xn(1:nb) = zero
  !xn(1)    = mu0    ! Initialize mu
  pi(1:m)  = zero
  iobj     = 0
  objadd   = zero
  nwcore   = lenz

  ! dumpLP.m generates slack bounds for SQOPT: Ax - s = 0
  ! Minos has Ax + s = 0, so we have to flip the bounds on s.

  z(1:m)     = -bl(n+1:nb)
  bl(n+1:nb) = -bu(n+1:nb)
  bu(n+1:nb) =   z(1:m)

  ! make quad-precision initial solution based on double
  call dq( xn, xnd, nb )

!!!!!!!!!!!!!!!!!!!! This was trying to solve an LP first to get feasible

!   nnCon0   = 0
!   nnObj0   = 0
!   nnJac0   = 0

!   call minoss( 'Cold', m, n, nb, ne, nname,         &
!                nnCon0, nnObj0, nnJac0,              &
!                iobj, objadd, names,                 &
!                a, ha, ka, bl, bu, name1, name2,     &
!                hs, xn, pi, rc,                      &
!                inform, mincor, ns, ninf, sinf, obj, &
!                z, nwcore )

!   write(nout, *) ' '
!   write(nout, *) 'Quad MINOS finished.'
!   write(nout, *) 'inform =', inform
!   write(nout, *) 'ninf   =', ninf
!   write(nout, *) 'sinf   =', sinf
!   write(nout, *) 'obj    =', obj

!   !======================================================
!   ! Warm start with 2nd SPECS file
!   !======================================================
!   call mispec( ispecs, inform )

!   if (inform .ge. 2) then
!      write(nout, *) 'No second SPECS file'
!      go to 900
!   end if

!   ! 20 Apr 2014:
!   ! Step 2 normally uses scaling (and then unscaling).
!   ! The unscaling might fill in the 2nd half of each quad word.
!   ! Round from Quad to Double and back to Quad again.

!   call qdq(  a, ne )
!   call qdq( bl, nb )
!   call qdq( bu, nb )

  iObj  = 0
  nnObj = 1
  bl(1) = mu0  ! For now, mu0 must be BELOW the OPTIMAL (maximized) value

  if (warm) then
      print *, 'Calling minoss. Warm start with provided basis (hs)'

      call minoss( 'Warm', m, n, nb, ne, nname,        &
          nncon, nnobj, nnjac,                &
          iobj, objadd, names,                &
          a, ha, ka, bl, bu, name1, name2,    &
          hs, xn, pi, rc,                     &
          inform, mincor, ns, ninf, sinf, obj, &
          z, nwcore )

      write(nout, *) ' '
      write(nout, *) 'Quad MINOS finished.'
      write(nout, *) 'inform =', inform
      write(nout, *) 'ninf   =', ninf
      write(nout, *) 'sinf   =', sinf
      write(nout, *) 'obj    =', obj

      ! Return xn rounded to double precision
      call qd( xn, xnd, nb)
  else
      print *, 'Calling minoss. Cold start'
      print *, 'Setting xn to zero and xn(1) to mu0'
      xn(1:nb) = zero
      xn(1)    = mu0    ! Initialize mu

      call minoss( 'Cold', m, n, nb, ne, nname,        &
          nncon, nnobj, nnjac,                &
          iobj, objadd, names,                &
          a, ha, ka, bl, bu, name1, name2,    &
          hs, xn, pi, rc,                     &
          inform, mincor, ns, ninf, sinf, obj, &
          z, nwcore )

      write(nout, *) ' '
      write(nout, *) 'Quad MINOS finished.'
      write(nout, *) 'inform =', inform
      write(nout, *) 'ninf   =', ninf
      write(nout, *) 'sinf   =', sinf
      write(nout, *) 'obj    =', obj

      ! Return xn rounded to double precision
      call qd( xn, xnd, nb)
  end if

900 close( iprint )
  close( ispecs )

  ! Return xn rounded to double precision
  call qd( xn, xnd, nb)

  !deallocate( pi, rc, xn )
  deallocate( pi, rc )
  deallocate( name1, name2 )
  deallocate( haA, kaA, aA)
  ! 22 Jul 2015: [LY] arrays below are now inputs
  !deallocate( bl, bu, ka, a, ha )

contains

  subroutine qdq( a, n )

    integer(ip), intent(in)    :: n
    real(qp),    intent(inout) :: a(n)

    ! 15 Apr 2014: First version of qdq.
    !              Round from Quad to Double and back to Quad.

    real(dp)                  :: da(n)   ! local array

    write(*,'(z32)') a(n)
    da = real( a,dp)
    a  = real(da,qp)
    write(*,'(z17)') da(n)
    write(*,'(z32)') a(n)
  end subroutine qdq

  ! LY, 20 Jul 2015: First version of qd.
  !                  Round quad vector to double for python
  subroutine qd( aq, ad, n )

      integer(ip),  intent(in)  :: n
      real(qp),     intent(in)  :: aq(n)
      real(dp),     intent(inout) :: ad(n)

      write(*,'(z32)') aq(n)
      ad = real(aq, dp)
      write(*,'(z17)') ad(n)
  end subroutine qd

  ! 15 Aug 2015: double to quad
  subroutine dq( aq, ad, n )
      integer(ip),  intent(in)  :: n
      real(dp),     intent(in)  :: ad(n)
      real(qp),    intent(inout):: aq(n)

      write(*,'(z17)') ad(n)
      aq = real(ad, qp)
      write(*,'(z32)') aq(n)
  end subroutine dq

end subroutine qsolveME

!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

subroutine funobj( mode, nnObj, x, fobj, gobj, nstate, nprob, z, lenz )

  implicit none
  integer,  intent(inout) :: mode
  integer,  intent(in)    :: nnObj, nstate, nprob, lenz
  real(16), intent(in)    :: x(nnObj)
  real(16), intent(out)   :: fobj, gobj(nnObj)
  real(16), intent(inout) :: z(lenz)

  !------------------------------------------------------------------
  ! This is funobj for tinyME-NLP.
  ! nnObj = 1.  The only nonlinear objective variable is max mu = x(1).
  !------------------------------------------------------------------

  fobj    = x(1)
  gobj(1) = 1.0

end subroutine funobj

!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

subroutine funcon( mode, nnCon, nnJac, neJac, x, &
                   f, gcon, nstate, nprob, z, lenz )

  use qmatrixA,  only: haA, kaA, aA

  implicit none
  integer,  intent(inout) :: mode
  integer,  intent(in)    :: nnCon, nnJac, neJac, nstate, nprob, lenz
  real(16), intent(in)    :: x(nnJac)
  real(16), intent(out)   :: f(nnCon), gcon(neJac)
  real(16), intent(inout) :: z(lenz)

  !------------------------------------------------------------------
  ! This is funcon for tinyME-NLP.
  ! Module qmatrixA holds a copy of A in arrays haA, kaA, aA.
  !------------------------------------------------------------------

  integer             :: i, j, k
  real(16)            :: Ai, mu, xj
  real(16), parameter :: zero = 0.0

  mu = x(1)

  if (nstate == 1) then   ! First call of funcon
     write(*,*) 'Calling funcon.  mu =', mu
     write(*,*) 'nnCon, nnJac, neJac', nncon, nnJac, neJac
     write(9,*) 'Calling funcon.  mu =', mu
  end if

  if (nstate >= 2) then   ! Last call of funcon
     write(*,*) 'Final value of   mu =', mu
     write(9,*) 'Final value of   mu =', mu
  end if

  gcon(1:nnCon) = zero    ! Initialize first column of Jacobian

  do j = 2, nnJac         ! f(1:nnCon) and all other columns of Jacobian
     xj = x(j)
   ! write(*,*) "j=", j
     do k = kaA(j), kaA(j+1)-1
        i       = haA(k)
        Ai      =  aA(k)
        gcon(i) = gcon(i) + Ai*xj  ! Accumulate Abar*xbar in col 1
        gcon(k) = mu*Ai
      ! write(*,*) "k=", k, "   i=", i
     end do
  end do

  f = mu*gcon(1:nnCon)

end subroutine funcon

!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

subroutine matmod
end subroutine matmod


SUBROUTINE HDMT

  ! *** SUBROUTINE HDMT EXECUTES THE FULL HYDRODYNAMIC AND MASS TRANSPORT
  ! *** TIME INTERGATION
  !
  !----------------------------------------------------------------------C
  ! CHANGE RECORD
  ! DATE MODIFIED     BY               DESCRIPTION
  !----------------------------------------------------------------------!
  !    2015-06       PAUL M. CRAIG     IMPLEMENTED SIGMA-Z (SGZ) IN EE7.3
  !    2014-08-12    D H CHUNG         SET EXPLICIT PRECISIONS OF INTEGER & REAL
  !    2012-09       Chung Dang        OMP
  !    05/01/2002    John Hamrick      Modified calls to calbal and budget subroutines
  !    09-22-2004    Paul M. Craig     Merged DS and TT versions with the 06-04-2004 TT code
  !
  !
  !**********************************************************************C
  !
  USE GLOBAL
  USE DRIFTER
  USE WINDWAVE ,ONLY:WINDWAVEINIT,WINDWAVETUR,READWAVECELLS
  USE HIFREQOUT
  USE RESTART_MODULE
  USE EFDCOUT
  USE CALCSERMOD,ONLY: CALCSER
#ifdef NCOUT
  USE MOD_NETCDF
#endif

  IMPLICIT NONE
  INTEGER(IK4) :: NS
  INTEGER :: L,ND,NTMP1,NTMP2,NTMP,K,IMAX,JMAX,KMAX
  INTEGER :: IMIN,JMIN,KMIN,NMD,ICALLTP,LS,LP
  INTEGER :: ILOGC
  INTEGER :: LN,LNW,LSE,LF,LL,LE,LW

  REAL :: SALMIN,HPPTMP,WTM,WTMP,TMP
  REAL :: DELVOL,SALMAX,TAUB2,DELTD2,DZDDELT
  REAL :: TAUBC,TAUBC2,UTMP,VTMP,CURANG,USGZ,VSGZ
  REAL :: CTIM
  REAL(RKD), EXTERNAL :: DSTIME
  REAL(RKD)           :: TTDS, T1TMP, TIMELAST         ! MODEL TIMING TEMPORARY VARIABLES
  REAL(RKD)           :: TIMEHARM

#ifdef _WIN
  LOGICAL, EXTERNAL :: KEY_PRESSED
  LOGICAL, EXTERNAL :: ISEXIT
#endif
  REAL(8)           :: DEL !RESTTIME
  LOGICAL           :: RES

  WRITE(*,'(A)')'STARTING HDMT 3TL'
  T1TMP=DSTIME(0)
  FOURDPI=4./PI
  RES = .TRUE.

  ! *** INITIALIZE TIME FOR INITIAL CONDITION COMPUTATIONS
  TIMESEC = DBLE(TCON)*DBLE(TBEGIN)
  TIMEDAY = DBLE(TCON)*DBLE(TBEGIN)/86400._8
  TIMEHARM = DBLE(TCON)*DBLE(TBEGIN) + 300.   ! *** 05 MINUTE INCREMENTS

  !**********************************************************************C
  !
  ! *** INITIALIZE COURNT NUMBER DIAGNOSTICS
  !
  !**********************************************************************!
  ! *** REINITIALIZE VARIABLES
  IF( ISRESTI == 0 )THEN
    DO L=2,LA
      H2P(L)=HP(L)
      H1P(L)=HP(L)
      H1U(L)=HU(L)
      H1UI(L)=HUI(L)
      H1V(L)=HV(L)
      H1VI(L)=HVI(L)
      UHDY1E(L)=UHDYE(L)
      VHDX1E(L)=VHDXE(L)
    ENDDO

    DO K=1,KC
      DO L=2,LA
        HPK(L,K) = HP(L)*DZC(L,K)
        H2PK(L,K) = HPK(L,K)
        H1PK(L,K) = HPK(L,K)
        U1(L,K)=U(L,K)
        V1(L,K)=V(L,K)
        UHDY1(L,K)=UHDY(L,K)
        VHDX1(L,K)=VHDX(L,K)
      ENDDO
    ENDDO
  ENDIF

  !**********************************************************************!
  ! *** INITIALIZE COURANT NUMBER DIAGNOSTICS
  IF( ISINWV == 1 )THEN
    DO K=1,KC
      DO L=2,LA
        CFLUUU(L,K)=0.
        CFLVVV(L,K)=0.
        CFLWWW(L,K)=0.
        CFLCAC(L,K)=0.
      ENDDO
    ENDDO
  ENDIF
  ILOGC=0

  !**********************************************************************C
  ! *** CALCULATE U AT V AND V AT U USING ENERGY CONSERVING WEIGHTING
  ! *** CALCULATE VELOCITY GRADIENTS
  !----------------------------------------------------------------------C
  DO L=2,LA
    LN=LNC(L)
    LS=LSC(L)
    LE=LEC(L)
    LW=LWC(L)
    LNW=LNWC(L)
    LSE=LSEC(L)

    UV(L)  = 0.25*( HP(LS) *(U(LSE,KSZV(L)) +U(LS,KSZV(L))  ) + HP(L) *(U(LE,KSZV(L)) +U(L,KSZV(L))  ) )*HVI(L)
    U1V(L) = 0.25*( H1P(LS)*(U1(LSE,KSZV(L))+U1(LS,KSZV(L)) ) + H1P(L)*(U1(LE,KSZV(L))+U1(L,KSZV(L)) ) )*H1VI(L)
    VU(L)  = 0.25*( HP(LW) *(V(LNW,KSZU(L)) +V(LW,KSZU(L))  ) + HP(L) *(V(LN,KSZU(L)) +V(L,KSZU(L))  ) )*HUI(L)
    V1U(L) = 0.25*( H1P(LW)*(V1(LNW,KSZU(L))+V1(LW,KSZU(L)) ) + H1P(L)*(V1(LN,KSZU(L))+V1(L,KSZU(L)) ) )*H1UI(L)

  ENDDO

  !**********************************************************************C
  ! *** CALCULATE WAVE BOUNDARY LAYER AND WAVE REYNOLDS STRESS FORCINGS
  IF( ISWAVE == 1 ) CALL WAVEBL
  IF( ISWAVE == 2 ) CALL WAVESXY
  IF( ISWAVE >= 3 .AND. NWSER > 0 )THEN
    CALL WINDWAVEINIT
    CALL WINDWAVETUR   !DHC FIRST CALL

    ! *** READ IN WAVE COMPUTATIONAL CELL LIST
    IF( IUSEWVCELLS /= 0 )THEN
      CALL READWAVECELLS
    ENDIF
  ENDIF

#ifdef NCOUT
  ! ** NETCDF INIT
  NC_DATESTAMP = ''
  IF (NCDFOUT > 0) THEN
    CALL READCORN
    IF( TIMEDAY >= TBEGNCDF ) CALL NETCDF_WRITE(NC_ID)
  ENDIF

  IF( HFREOUT == 1 )THEN
    DO NS=1,NSUBSET
      CALL HFREHYOUT(1,NS)
      CALL HFREWCOUT(1,NS)
      CALL HFREWQOUT(1,NS)
      CALL HFRERPEMOUT(1,NS)
    ENDDO
  ENDIF
#endif

  !**********************************************************************C
  ! *** FIRST CALL TO INITIALIZE BOTTOM STRESS COEFFICIENTS
  ISTL=3
  IS2TL=0
  CALL CALTBXY(ISTL,IS2TL)

  !**********************************************************************C
  ! *** CALCULATE HORIZONTAL VISCOSITY AND DIFFUSIVE MOMENTUM FLUXES
  IF( ISHDMF >= 1 ) CALL CALHDMF3(ISTL)

  !**********************************************************************C
  ! *** CALCULATE BOTTOM AND SURFACE STRESS AT TIME LEVEL (N-1) AND N
  !----------------------------------------------------------------------C
  N=-1
  CALL CALTSXY

  DO L=2,LA
    TBX1(L)=(AVCON1*H1UI(L) + STBX(L)*SQRT(V1U(L)*V1U(L) + U1(L,KSZ(L))*U1(L,KSZ(L)))) * U1(L,KSZ(L))
    TBY1(L)=(AVCON1*H1VI(L) + STBY(L)*SQRT(U1V(L)*U1V(L) + V1(L,KSZ(L))*V1(L,KSZ(L)))) * V1(L,KSZ(L))
    TSX1(L)=TSX(L)
    TSY1(L)=TSY(L)
  ENDDO

  !**********************************************************************!
  ! *** SECOND CALL TO INITIALIZE BOTTOM STRESS COEFFICIENTS
  CALL CALTBXY(ISTL,IS2TL)

  !**********************************************************************C
  ! *** SET BOTTOM AND SURFACE STRESSES
  DO L=2,LA
    USGZ=U(L,KSZU(L))
    VSGZ=V(L,KSZV(L))
    TBX(L)=(AVCON1*HUI(L)+STBX(L)*SQRT(VU(L)*VU(L)+USGZ*USGZ))*USGZ
    TBY(L)=(AVCON1*HVI(L)+STBY(L)*SQRT(UV(L)*UV(L)+VSGZ*VSGZ))*VSGZ
  ENDDO

  N=0
  CALL CALTSXY

  ! *** SET DEPTH DEVIATION FROM UNIFORM FLOW ON FLOW FACES
  DO L=2,LA
    HDFUFX(L)=1.
    HDFUFY(L)=1.
    HDFUF(L)=1.
  ENDDO

  ! *** SET CORNER CORRECTIONS
  DO L=2,LA
    WCOREST(L)=1.
    WCORWST(L)=1.
    WCORNTH(L)=1.
    WCORSTH(L)=1.
  ENDDO

  !**********************************************************************!
  ! *** SET BOTTOM AND SURFACE TURBULENT INTENSITY SQUARED
  IF( ISWAVE == 0 )THEN
    DO L=2,LA
      TVAR3W(L)=TSX1(LEC(L))
      TVAR3S(L)=TSY1(LNC(L))
      TVAR3E(L)=TBX1(LEC(L))
      TVAR3N(L)=TBY1(LNC(L))
    ENDDO

    DO L=2,LA
      QQ1(L,0)  = 0.5*CTURB2*SQRT((RSSBCE(L)*TVAR3E(L)+RSSBCW(L)*TBX1(L))**2 + (RSSBCN(L)*TVAR3N(L)+RSSBCS(L)*TBY1(L))**2)
      QQ1(L,KC) = 0.5*CTURB2*SQRT((RSSBCE(L)*TVAR3W(L)+RSSBCW(L)*TSX1(L))**2 + (RSSBCN(L)*TVAR3S(L)+RSSBCS(L)*TSY1(L))**2)
    ENDDO

    DO L=2,LA
      TVAR3W(L) = TSX(LEC(L))
      TVAR3S(L) = TSY(LNC(L))
      TVAR3E(L) = TBX(LEC(L))
      TVAR3N(L) = TBY(LNC(L))
    ENDDO

    DO L=2,LA
      QQ(L,0)  = 0.5*CTURB2*SQRT( (RSSBCE(L)*TVAR3E(L) + RSSBCW(L)*TBX(L))**2  + (RSSBCN(L)*TVAR3N(L) + RSSBCS(L)*TBY(L))**2 )
      QQ(L,KC) = 0.5*CTURB2*SQRT( (RSSBCE(L)*TVAR3W(L) + RSSBCW(L)*TSX(L))**2  + (RSSBCN(L)*TVAR3S(L) + RSSBCS(L)*TSY(L))**2 )
      QQSQR(L,0) = SQRT(QQ(L,0))
    ENDDO
  ENDIF    ! *** END OF ISWAVE=0

  !**********************************************************************!
  ! *** SET BOTTOM AND SURFACE TURBULENT INTENSITY SQUARED
  !----------------------------------------------------------------------!
  IF( ISWAVE >= 1 )THEN
    DO L=2,LA
      TVAR3S(L)=TSY1(LNC(L))
      TVAR3W(L)=TSX1(LEC(L))
      TVAR3E(L)=TBX1(LEC(L))
      TVAR3N(L)=TBY1(LNC(L))
    ENDDO

    DO L=2,LA
      TAUBC2 = (RSSBCE(L)*TVAR3E(L)+RSSBCW(L)*TBX(L))**2 + (RSSBCN(L)*TVAR3N(L)+RSSBCS(L)*TBY(L))**2
      TAUBC=0.5*SQRT(TAUBC2)
      CTAUC(L)=TAUBC
      UTMP = 0.5*STCUV(L)*( U1(LEC(L),KSZ(L)) + U1(L,KSZ(L)) )+1.E-12
      VTMP = 0.5*STCUV(L)*( V1(LNC(L),KSZ(L)) + V1(L,KSZ(L)) )
      CURANG=ATAN2(VTMP,UTMP)
      TAUB2 = TAUBC*TAUBC + (QQWV3(L)*QQWV3(L)) + 2.*TAUBC*QQWV3(L)*COS(CURANG-WV(L).DIR)
      TAUB2 = MAX(TAUB2,0.)
      QQ1(L,0)  = CTURB2*SQRT(TAUB2)
      QQ1(L,KC) = 0.5*CTURB2*SQRT( (TVAR3W(L)+TSX1(L))**2 + (TVAR3S(L)+TSY1(L))**2 )
    ENDDO

    DO L=2,LA
      TVAR3S(L)=TSY(LNC(L))
      TVAR3W(L)=TSX(LEC(L))
      TVAR3E(L)=TBX(LEC(L)   )
      TVAR3N(L)=TBY(LNC(L))
    ENDDO

    DO L=2,LA
      TAUBC2 = 0.25*( (RSSBCE(L)*TVAR3E(L)+RSSBCW(L)*TBX(L))**2 + (RSSBCN(L)*TVAR3N(L)+RSSBCS(L)*TBY(L))**2 )
      TAUBC = SQRT(TAUBC2)
      CTAUC(L) = TAUBC
      UTMP = 0.5*STCUV(L)*(U(LEC(L),KSZU(LEC(L))) + U(L,KSZU(L)))+1.E-12
      VTMP = 0.5*STCUV(L)*(V(LN,KSZV(LNC(L)))     + V(L,KSZV(L)))
      CURANG = ATAN2(VTMP,UTMP)
      TAUB2 =  TAUBC*TAUBC + (QQWV3(L)*QQWV3(L)) + 2.*TAUBC*QQWV3(L)*COS(CURANG-WV(L).DIR)
      TAUB2 =  MAX(TAUB2,0.)
      QQ(L,0)  = CTURB2*SQRT(TAUB2)
      QQ(L,KC) = 0.5*CTURB2*SQRT( (TVAR3W(L)+TSX(L))**2 + (TVAR3S(L)+TSY(L))**2 )
      QQSQR(L,0) = SQRT(QQ(L,0))
    ENDDO
  ENDIF

  ! ***  SET GRAIN STRESS
  IF( ISTRAN(6) >= 1 .OR. ISTRAN(7) >= 1 )THEN
    DO L=2,LA
      TAUBSED(L)=QQ(L,0)/CTURB2
      TAUBSND(L)=QQ(L,0)/CTURB2
    ENDDO
  ENDIF

  !**********************************************************************C
  !
  ! ***  SET SWITCHES FOR THREE TIME LEVEL STEP
  !
  ISTL=3
  IS2TL=0
  DELT=DT2
  DELTD2=DT
  DZDDELT=DZ/DELT
  ROLD=0.
  RNEW=1.

  !**********************************************************************C
  ! *** BEGIN TIME LOOP FOR FULL HYDRODYNAMIC AND MASS TRANSPORT
  ! *** CALCULATION

  ! *** SET CYCLE COUNTER AND CALL TIMER
  !**********************************************************************
  NTIMER=0
  N=0
  TIMELAST = TIMEDAY + TIMERST

  ! *** INITIALIZE & RECORD TIME
  TIMEDAY=TCON*TBEGIN/86400.
  !RESTTIME = TIMEDAY+HREST/24.
  CALL TIMELOG(N,TIMEDAY,OUTDIR)

  NTIMER=1

  !***************************************************************************
  !***************************************************************************
  ! *** BEGINNING OF THE MAIN TIME ITERATION LOOP FOR TWO TIME LEVEL SOLUTION
  !***************************************************************************
  !***************************************************************************
  DO 1000 N=1,NTS

    TIMESEC = DBLE(DT)*DBLE(N)+DBLE(TCON)*DBLE(TBEGIN)
    TIMEDAY = TIMESEC/86400._8
    NITER = N

    ILOGC=ILOGC+1

    IF( N <= NLTS )THEN
      SNLT=0.
    ELSEIF( N > NLTS .AND. N <= NTTS )THEN
      NTMP1=N-NLTS
      NTMP2=NTTS-NLTS+1
      SNLT=FLOAT(NTMP1)/FLOAT(NTMP2)
    ELSE
      SNLT=1.
    ENDIF

    ! *** SET THE GRAVITY ACCELERATION
    IF( N <= NTSVB )THEN
      GP=GPO*(FLOAT(N)/FLOAT(NTSVB))
    ELSE
      GP=GPO
    ENDIF

    !----------------------------------------------------------------------C
    !
    ! *** INITIALIZE VOLUME, MASS, MOMENTUM, AND ENERGY BALANCE
    !
    IF( NCTBC /= NTSTBC .AND. ISBAL >= 1 )THEN
      CALL CALBAL1
      NTMP=MOD(N,2)
      IF( NTMP == 0 )THEN
        CALL CBALEV1
      ELSE
        CALL CBALOD1
      ENDIF
    ENDIF

    !  ** INITIALIZE SEDIMENT BUDGET CALCULATION   (DLK 10/15)
    IF( NCTBC /= NTSTBC .AND. ISSBAL >= 1 )THEN
      CALL BUDGET1
    ENDIF

    !----------------------------------------------------------------------C
    ! *** REENTER HERE FOR TWO TIME LEVEL CORRECTION
    500 CONTINUE

    !**********************************************************************C
    ! *** CALCULATE VERTICAL VISCOSITY AND DIFFUSIVITY AT TIME LEVEL (N)
    TTDS=DSTIME(0)
    IF( KC > 1 )THEN
      CALL CALAVB
    ENDIF
    TAVB=TAVB+(DSTIME(0)-TTDS)

    !**********************************************************************C
    ! *** CALCULATE WAVE BOUNDARY LAYER AND WAVE REYNOLDS STRESS FORCINGS
    IF( ISTL == 3 )THEN
      TTDS=DSTIME(0)
      IF( ISWAVE == 1 ) CALL WAVEBL
      IF( ISWAVE == 2 ) CALL WAVESXY
      IF( ISWAVE >= 3 .AND. NWSER > 0 ) CALL WINDWAVETUR   !DHC NEXT CALL
      TTBXY=TTBXY+(DSTIME(0)-TTDS)
    ENDIF

    !**********************************************************************C
    ! *** CALCULATE EXPLICIT MOMENTUM EQUATION TERMS
    ! *** CALEXP   -  PRODUCTION VERSION WITH HORIZONTAL MOMENTUM SOURCE
    ! ***             AND 3D IMPLICIT VEGETATION DRAG
    TTDS=DSTIME(0)
    CALL CALEXP (ISTL)
    TCEXP=TCEXP+(DSTIME(0)-TTDS)

    !**********************************************************************C
    ! *** UPDATE TIME VARIABLE VOLUME SOURCES AND SINKS, CONCENTRATIONS,
    ! *** VEGETATION CHARACTERISTICS AND SURFACE ELEVATIONS
    CALL CALCSER (ISTL)
    CALL CALVEGSER
    CALL CALQVS (ISTL)
    PSERT(0)=0.
    IF( NPSER >= 1 ) CALL CALPSER

    !**********************************************************************C
    ! *** SOLVE EXTERNAL MODE EQUATIONS FOR P, UHDYE, AND VHDXE
    TTDS=DSTIME(0)
    CALL CALPUV9C(ISTL)
    TPUV=TPUV+(DSTIME(0)-TTDS)

    !**********************************************************************C
    ! *** ADVANCE TIME SNAPSHOT INTERNAL VARIABLES FOR THREE TIME LEVEL STEP
    IF( ISTL == 3 )THEN
      !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ND,K,LP,L)
      DO ND=1,NDM
        DO K=1,KC
          DO LP=1,LLWET(K,ND)
            L=LKWET(LP,K,ND)
            UHDYF2(L,K)=UHDYF1(L,K)   ! *** FLOW BY LAYER FOR THE ENTIRE DEPTH
            UHDYF1(L,K)=UHDYF(L,K)
            VHDXF2(L,K)=VHDXF1(L,K)
            VHDXF1(L,K)=VHDXF(L,K)

            UHDY2(L,K)=UHDY1(L,K)     ! *** FLOW BY LAYER
            UHDY1(L,K)=UHDY(L,K)
            VHDX2(L,K)=VHDX1(L,K)
            VHDX1(L,K)=VHDX(L,K)

            U2(L,K)=U1(L,K)           ! *** N-2 TIME, NOT INTERVAL AVERAGE
            V2(L,K)=V1(L,K)           ! *** N-2 TIME, NOT INTERVAL AVERAGE
            U1(L,K)=U(L,K)
            V1(L,K)=V(L,K)
            W2(L,K)=W1(L,K)           ! *** N-2 TIME, NOT INTERVAL AVERAGE
            W1(L,K)=W(L,K)
          ENDDO
        ENDDO
      ENDDO
      !$OMP END PARALLEL DO

    ENDIF

    !**********************************************************************C
    ! *** ADVANCE TIME VARIABLE SURFACE WIND STRESS AND LOAD INTO INTERNAL
    ! *** MODE FORCING
    !----------------------------------------------------------------------C
    IF( ISTL == 3 )THEN
      TTDS=DSTIME(0)

      !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ND,LF,LL,LP,L)
      DO ND=1,NDM
        LF=(ND-1)*LDMWET+1
        LL=MIN(LF+LDMWET-1,LAWET)
        DO LP=LF,LL
          L=LWET(LP)
          TSX1(L)=TSX(L)
          TSY1(L)=TSY(L)
        ENDDO
      ENDDO
      !$OMP END PARALLEL DO

      CALL CALTSXY

      !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ND,LF,LL,LP,L)
      DO ND=1,NDM
        LF=(ND-1)*LDMWET+1
        LL=MIN(LF+LDMWET-1,LAWET)
        DO LP=LF,LL
          L=LWET(LP)
          DU(L,KS) = DU(L,KS) - CDZUU(L,KS)*TSX(L)
          DV(L,KS) = DV(L,KS) - CDZUV(L,KS)*TSY(L)
        ENDDO
      ENDDO
      !$OMP END PARALLEL DO

      TTBXY=TTBXY+(DSTIME(0)-TTDS)
    ENDIF

    !**********************************************************************C
    ! *** SOLVE INTERNAL SHEAR MODE EQUATIONS FOR U, UHDY, V, VHDX, AND W
    ! *** USING THE INTERNAL SHEARS STORED IN DU & DV
    TTDS=DSTIME(0)
    IF( KC > 1 )THEN
      CALL CALUVW (ISTL)
    ELSE
      !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ND,LF,LL,LP,L)
      DO ND=1,NDM
        LF=(ND-1)*LDMWET+1
        LL=MIN(LF+LDMWET-1,LAWET)
        DO LP=LF,LL
          L=LWET(LP)
          UHDYF(L,1) = UHDYE(L)
          UHDY(L,1)  = UHDYE(L)
          U(L,1)=UHDYE(L)*HUI(L)*DYIU(L)
          VHDXF(L,1) = VHDXE(L)
          VHDX(L,1)  = VHDXE(L)
          V(L,1)=VHDXE(L)*HVI(L)*DXIV(L)
          W(L,1)=0.
        ENDDO
      ENDDO
      !$OMP END PARALLEL DO
      CALL CALUVW (ISTL)
    ENDIF
    TUVW=TUVW+(DSTIME(0)-TTDS)

    !**********************************************************************C
    ! *** CALCULATE SALINITY, TEMPERATURE, DYE AND SEDIMENT CONCENTRATIONS
    ! *** AT TIME LEVEL (N+1)
    IF( ISTRANACTIVE > 0 )  CALL CALCONC (ISTL,IS2TL)

    !----------------------------------------------------------------------C
    ! *** CHECK RANGE OF SALINITY AND DYE CONCENTRATION
    IF( ISMMC == 1 .AND. DEBUG )THEN

      SALMAX=-100000.
      SALMIN=100000.
      DO K=1,KC
        DO L=2,LA
          IF( SAL(L,K) > SALMAX )THEN
            SALMAX=SAL(L,K)
            IMAX=IL(L)
            JMAX=JL(L)
            KMAX=K
          ENDIF
          IF( SAL(L,K) < SALMIN )THEN
            SALMIN=SAL(L,K)
            IMIN=IL(L)
            JMIN=JL(L)
            KMIN=K
          ENDIF
        ENDDO
      ENDDO

      WRITE(6,6001)N
      WRITE(6,6002)SALMAX,IMAX,JMAX,KMAX
      WRITE(6,6003)SALMIN,IMIN,JMIN,KMIN

      SALMAX=-100000.
      SALMIN=100000.
      DO K=1,KC
        DO L=2,LA
          IF( DYE(L,K) > SALMAX )THEN
            SALMAX=DYE(L,K)
            IMAX=IL(L)
            JMAX=JL(L)
            KMAX=K
          ENDIF
          IF( DYE(L,K) < SALMIN )THEN
            SALMIN=DYE(L,K)
            IMIN=IL(L)
            JMIN=JL(L)
            KMIN=K
          ENDIF
        ENDDO
      ENDDO

      WRITE(6,6004)SALMAX,IMAX,JMAX,KMAX
      WRITE(6,6005)SALMIN,IMIN,JMIN,KMIN

      SALMAX=-100000.
      SALMIN=100000.
      DO K=1,KC
        DO L=2,LA
          IF( SFL(L,K) > SALMAX )THEN
            SALMAX=SFL(L,K)
            IMAX=IL(L)
            JMAX=JL(L)
            KMAX=K
          ENDIF
          IF( SFL(L,K) < SALMIN )THEN
            SALMIN=SFL(L,K)
            IMIN=IL(L)
            JMIN=JL(L)
            KMIN=K
          ENDIF
        ENDDO
      ENDDO

      WRITE(6,6006)SALMAX,IMAX,JMAX,KMAX
      WRITE(6,6007)SALMIN,IMIN,JMIN,KMIN

    ENDIF

    IF( ISMMC == 2 .AND. DEBUG )THEN
      SALMAX=-100000.
      SALMIN=100000.
      DO K=1,KC
        DO L=2,LA
          IF( TEM(L,K) > SALMAX )THEN
            SALMAX=TEM(L,K)
            IMAX=IL(L)
            JMAX=JL(L)
            KMAX=K
          ENDIF
          IF( TEM(L,K) < SALMIN )THEN
            SALMIN=TEM(L,K)
            IMIN=IL(L)
            JMIN=JL(L)
            KMIN=K
          ENDIF
        ENDDO
      ENDDO

      WRITE(6,6001)N
      WRITE(6,6008)SALMAX,IMAX,JMAX,KMAX
      WRITE(6,6009)SALMIN,IMIN,JMIN,KMIN

    ENDIF

   6001 FORMAT('  N=',I10)
   6002 FORMAT('  SALMAX=',F14.4,5X,'I,J,K=',(3I10))
   6003 FORMAT('  SALMIN=',F14.4,5X,'I,J,K=',(3I10))
   6004 FORMAT('  DYEMAX=',F14.4,5X,'I,J,K=',(3I10))
   6005 FORMAT('  DYEMIN=',F14.4,5X,'I,J,K=',(3I10))
   6006 FORMAT('  SFLMAX=',F14.4,5X,'I,J,K=',(3I10))
   6007 FORMAT('  SFLMIN=',F14.4,5X,'I,J,K=',(3I10))
   6008 FORMAT('  TEMMAX=',F14.4,5X,'I,J,K=',(3I10))
   6009 FORMAT('  TEMMIN=',F14.4,5X,'I,J,K=',(3I10))

    !**********************************************************************C
    !
    ! *** CALCULATE SHELL FISH LARVAE AND/OR WATER QUALITY CONSTITUENT
    ! *** CONCENTRATIONS AT TIME LEVEL (N+1) AFTER SETTING DOUBLE TIME
    ! *** STEP TRANSPORT FIELD
    !
    !----------------------------------------------------------------------C
    IF( ISWQFLUX == 1 )THEN
      NTMP=MOD(N,2)
      IF( NTMP == 0 .AND. ISTL == 3 )THEN

        ! *** CALCULATE CONSERVATION OF VOLUME FOR THE WATER QUALITY ADVECTION
        !$OMP PARALLEL DEFAULT(SHARED)
        !$OMP DO PRIVATE(ND,LF,LL,LP,L)
        DO ND=1,NDM
          LF=(ND-1)*LDMWET+1
          LL=MIN(LF+LDMWET-1,LAWET)
          DO LP=LF,LL
            L=LWET(LP)
            !UHDY2E(L)=0.
            !VHDX2E(L)=0.
            HWQ(L) = 0.25*(H2P(L) + 2.*H1P(L)+HP(L))
          ENDDO
        ENDDO
        !$OMP END DO

        !$OMP DO PRIVATE(ND,K,LP,L)
        DO ND=1,NDM
          DO K=1,KC
            DO LP=1,LLWET(K,ND)
              L=LKWET(LP,K,ND)
              UHDYWQ(L,K) = 0.5*(UHDY1(L,K)+UHDY2(L,K))
              VHDXWQ(L,K) = 0.5*(VHDX1(L,K)+VHDX2(L,K))
              !UHDY2E(L) = UHDY2E(L)+UHDYWQ(L,K)
              !VHDX2E(L) = VHDX2E(L)+VHDXWQ(L,K)
              UWQ(L,K) = 0.5*(U1(L,K)+U2(L,K))
              VWQ(L,K) = 0.5*(V1(L,K)+V2(L,K))
            ENDDO
          ENDDO
        ENDDO
        !$OMP END DO

        !$OMP DO PRIVATE(ND,LF,LL,LP,L)
        DO ND=1,NDM
          LF=(ND-1)*LDMWET+1
          LL=MIN(LF+LDMWET-1,LAWET)
          DO LP=LF,LL
            L=LWET(LP)
            TVAR3E(L) = UHDY2E(LEC(L))
            TVAR3N(L) = VHDX2E(LNC(L))
          ENDDO
        ENDDO
        !$OMP END DO

        !$OMP DO PRIVATE(ND,K,LP,L)
        DO ND=1,NDM
          DO K=1,KC
            DO LP=1,LLWET(K,ND)
              L=LKWET(LP,K,ND)
              TVAR2E(L,K) = UHDYWQ(LEC(L),K)
              TVAR2N(L,K) = VHDXWQ(LNC(L),K)
            ENDDO
          ENDDO
        ENDDO
        !$OMP END DO

        !$OMP DO PRIVATE(ND,K,LP,L)
        DO ND=1,NDM
          DO K=1,KS
            DO LP=1,LLWET(K,ND)
              L=LKWET(LP,K,ND)
              WWQ(L,K) = SWB(L)*( WWQ(L,K-1)-DZC(L,K)*(TVAR2E(L,K)-UHDYWQ(L,K)-TVAR3E(L)+UHDY2E(L)             &
                                                  +TVAR2N(L,K)-VHDXWQ(L,K)-TVAR3N(L)+VHDX2E(L))*DXYIP(L) ) &
                       + SWB(L)*( QSUM(L,K)-DZC(L,K)*QSUME(L) )*DXYIP(L)
            ENDDO
          ENDDO
        ENDDO
        !$OMP END DO

        IF( ISICM >= 1 )THEN
          !$OMP DO PRIVATE(ND,LF,LL,LP,L,HPPTMP)
          DO ND=1,NDM
            LF=(ND-1)*LDMWET+1
            LL=MIN(LF+LDMWET-1,LAWET)
            DO LP=LF,LL
              L=LWET(LP)
              HPPTMP=H2WQ(L)+DT2*DXYIP(L)*( QSUME(L) - (TVAR3E(L)-UHDY2E(L)+TVAR3N(L)-VHDX2E(L)) )
              HWQ(L)=SPB(L)*HPPTMP+(1.-SPB(L))*HWQ(L)
            ENDDO
          ENDDO
          !$OMP END DO
        ENDIF
        !$OMP END PARALLEL

        ! *** ADD CHANNEL INTERACTIONS
        IF( MDCHH >= 1 )THEN
          DO NMD=1,MDCHH
            IF( MDCHTYP(NMD) == 1 )THEN
              HWQ(LMDCHH(NMD))=HWQ(LMDCHH(NMD))  +DT2*DXYIP(LMDCHH(NMD))*(QCHANU(NMD))
              HWQ(LMDCHU(NMD))=HWQ(LMDCHU(NMD))  -DT2*DXYIP(LMDCHU(NMD))*(QCHANU(NMD))
            ENDIF
            IF( MDCHTYP(NMD) == 2 )THEN
              HWQ(LMDCHH(NMD))=HWQ(LMDCHH(NMD)) + DT2*DXYIP(LMDCHH(NMD))*(QCHANV(NMD))
              HWQ(LMDCHV(NMD))=HWQ(LMDCHV(NMD)) - DT2*DXYIP(LMDCHV(NMD))*(QCHANV(NMD))
            ENDIF
            IF( MDCHTYP(NMD) == 3 )THEN
              HWQ(LMDCHH(NMD))=HWQ(LMDCHH(NMD)) + DT2*DXYIP(LMDCHH(NMD))*(QCHANU(NMD)) + DT2*DXYIP(LMDCHH(NMD))*(QCHANV(NMD))
              HWQ(LMDCHU(NMD))=HWQ(LMDCHU(NMD)) - DT2*DXYIP(LMDCHU(NMD))*(QCHANU(NMD))
              HWQ(LMDCHV(NMD))=HWQ(LMDCHV(NMD)) - DT2*DXYIP(LMDCHV(NMD))*(QCHANV(NMD))
            ENDIF
          ENDDO
        ENDIF      ! *** END ADD CHANNEL INTERACTIONS

        ! *** CALL WATER QAULITY KINETICS AND TRANSPORT
        IF( ISTRAN(8) >= 1 ) CALL WQ3D(ISTL,IS2TL)
        IF( ISTRAN(4) >= 1 ) CALL CALSFT(ISTL,IS2TL)

        !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ND,LF,LL,LP,L)
        DO ND=1,NDM
          LF=(ND-1)*LDMWET+1
          LL=MIN(LF+LDMWET-1,LAWET)
          DO LP=LF,LL
            L=LWET(LP)
            H2WQ(L)=HWQ(L)
          ENDDO
        ENDDO
        !$OMP END PARALLEL DO

      ENDIF
    ENDIF         ! *** END OF WQ SECTION

    !**********************************************************************C
    ! *** UPDATE BUOYANCY AND CALCULATE NEW BUOYANCY USING AN EQUATION OF STATE
    IF( BSC > 1.E-6 )THEN
      IF( ISTL == 3 )THEN
        CALL CALBUOY(.TRUE.)
      ELSE
        CALL CALBUOY(.FALSE.)
      ENDIF
    ENDIF

    IF( NCTBC /= NTSTBC .AND. ISBAL >= 1 )THEN
      CALL CALBAL4
      NTMP=MOD(N,2)
      IF( NTMP == 0 )THEN
        CALL CBALEV4
      ELSE
        CALL CBALOD4
      ENDIF
    ENDIF

    !**********************************************************************C
    !
    ! *** CALCULATE U AT V AND V AT U AT TIME LEVEL (N+1)

    !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ND,LF,LL,LP,L,LN,LS,LNW,LSE,LE,LW)            &
    !$OMP             SHARED(NDM,LDMWET,LAWET,LWET,LEC,LNC,LSC,LWC,LNWC,LSEC,LSWC,LKSZ)   &
    !$OMP             SHARED(SUB,SVB,UV,VU,HP,U,V,U1V,V1U,HVI,HUI,KSZ,KSZU,KSZV,HPW,HPE,HPN,HPS)
    DO ND=1,NDM
      LF=(ND-1)*LDMWET+1
      LL=MIN(LF+LDMWET-1,LAWET)
      DO LP=LF,LL
        L=LWET(LP)
        LN=LNC(L)
        LS=LSC(L)
        LE=LEC(L)
        LW=LWC(L)
        LNW=LNWC(L)
        LSE=LSEC(L)

        U1V(L) = UV(L)
        V1U(L) = VU(L)

        IF( LKSZ(LS,KSZ(L)) )THEN
          UV(L)=0.5*( U(LE,KSZ(L)) + U(L,KSZ(L)) )
        ELSE
          UV(L)= 0.25*( HP(LS)*( U(LSE,KSZU(LSE)) + U(LS,KSZU(LS)) ) + HP(L)*( U(LE,KSZU(LE)) + U(L,KSZU(L)) ) )*HVI(L)
        ENDIF
        IF( LKSZ(LW,KSZ(L)) )THEN
          VU(L)= 0.5*( V(LN,KSZ(L)) + V(L,KSZ(L)) )
        ELSE
          VU(L)= 0.25*( HP(LW)*( V(LNW,KSZV(LNW)) + V(LW,KSZV(LW)) ) + HP(L)*( V(LN,KSZV(LN)) + V(L,KSZV(L)) ) )*HUI(L)
        ENDIF
      ENDDO
    ENDDO
    !$OMP END PARALLEL DO

    !**********************************************************************C
    ! *** CALCULATE HORIZONTAL VISCOSITY AND MOMENTUM DIFFUSION FLUXES
    ! *** AT TIME LEVEL (N)
    IF( ISHDMF >= 1 )THEN
      TTDS=DSTIME(0)
      CALL CALHDMF3(ISTL)
      THMDF=THMDF+(DSTIME(0)-TTDS)
    ENDIF

    !**********************************************************************C
    !
    ! *** UPDATE BOTTOM STRESSES AND SURFACE AND BOTTOM TURBULENT
    ! *** INTENSITIES
    IF( ISTL == 3 )THEN
      IF( ISCDMA == 2 )THEN
        !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ND,LF,LL,LP,L)
        DO ND=1,NDM
          LF=(ND-1)*LDMWET+1
          LL=MIN(LF+LDMWET-1,LAWET)
          DO LP=LF,LL
            L=LWET(LP)
            TBX1(L)   = TBX(L)
            TBY1(L)   = TBY(L)
            QQ2(L,0)  = QQ(L,0)+QQ1(L,0)
            QQ2(L,KC) = QQ(L,KC)+QQ1(L,KC)
            QQ1(L,0)  = QQ(L,0)
            QQ1(L,KC) = QQ(L,KC)
          ENDDO
        ENDDO
        !$OMP END PARALLEL DO

      ELSE  ! *** IF( ISCDMA < 2 )THEN

        !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ND,LF,LL,LP,L)
        DO ND=1,NDM
          LF=(ND-1)*LDMWET+1
          LL=MIN(LF+LDMWET-1,LAWET)
          DO LP=LF,LL
            L=LWET(LP)
            TBX1(L)   = TBX(L)
            TBY1(L)   = TBY(L)
            QQ2(L,0)  = QQ1(L,0)+QQ1(L,0)
            QQ2(L,KC) = QQ1(L,KC)+QQ1(L,KC)
            QQ1(L,0)  = QQ(L,0)
            QQ1(L,KC) = QQ(L,KC)
          ENDDO
        ENDDO
        !$OMP END PARALLEL DO

      ENDIF
    ENDIF

    !**********************************************************************C
    !
    ! *** CALCULATE BOTTOM STRESS AT LEVEL (N+1)

    TTDS=DSTIME(0)
    CALL CALTBXY(ISTL,IS2TL)

    !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ND,LF,LL,LP,L,USGZ,VSGZ)       &
    !$OMP             SHARED(NDM,LDMWET,LAWET,LWET,KSZ,KSZU,KSZV)          &
    !$OMP             SHARED(AVCON1, TBX,HUI,STBX,VU,U, TBY,HVI,STBY,UV,V)
    DO ND=1,NDM
      LF=(ND-1)*LDMWET+1
      LL=MIN(LF+LDMWET-1,LAWET)

      DO LP=LF,LL
        L=LWET(LP)
        USGZ=U(L,KSZU(L))
        VSGZ=V(L,KSZV(L))
        TBX(L) = ( AVCON1*HUI(L) + STBX(L)*SQRT( VU(L)*VU(L) + USGZ*USGZ ) )*USGZ
        TBY(L) = ( AVCON1*HVI(L) + STBY(L)*SQRT( UV(L)*UV(L) + VSGZ*VSGZ ) )*VSGZ
      ENDDO
    ENDDO
    !$OMP END PARALLEL DO

    TTBXY=TTBXY+(DSTIME(0)-TTDS)

    !**********************************************************************C
    !
    ! *** SET BOTTOM AND SURFACE TURBULENT INTENSITY SQUARED AT (N+1)
    !
    !----------------------------------------------------------------------C
    TTDS=DSTIME(0)
    IF( ISWAVE == 0 )THEN

      !*** STANDARD CALCULATIONS - NO CORNER CORRECTS
      !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ND,LF,LL,LP,L,TMP)
      DO ND=1,NDM
        LF=(ND-1)*LDMWET+1
        LL=MIN(LF+LDMWET-1,LAWET)

        DO LP=LF,LL
          L=LWET(LP)
          TVAR3W(L)=TSX(LEC(L))
          TVAR3S(L)=TSY(LNC(L))
          TVAR3E(L)=TBX(LEC(L))
          TVAR3N(L)=TBY(LNC(L))
        ENDDO

        DO LP=LF,LL
          L=LWET(LP)
          TMP = ( RSSBCE(L)*TVAR3E(L) + RSSBCW(L)*TBX(L) )**2 + ( RSSBCN(L)*TVAR3N(L) + RSSBCS(L)*TBY(L) )**2
          QQ(L,0)  = 0.5*CTURB2*SQRT(TMP)
          !QQ(L,0)  = 0.5*CTURB2*SQRT( (TVAR3E(L)+TBX(L))**2 + (TVAR3N(L)+TBY(L))**2 )

          TMP = ( RSSBCE(L)*TVAR3W(L) + RSSBCW(L)*TSX(L) )**2 + ( RSSBCN(L)*TVAR3S(L) + RSSBCS(L)*TSY(L) )**2
          QQ(L,KC) = 0.5*CTURB2*SQRT(TMP)
          !QQ(L,KC) = 0.5*CTURB2*SQRT( (TVAR3W(L)+TSX(L))**2 + (TVAR3S(L)+TSY(L))**2 )

          QQSQR(L,0) = SQRT(QQ(L,0))
        ENDDO
      ENDDO
      !$OMP END PARALLEL DO

    ENDIF

    !**********************************************************************C
    !
    ! *** SET BOTTOM AND SURFACE TURBULENT INTENSITY SQUARED AT (N+1)
    !
    !----------------------------------------------------------------------C
    IF( ISWAVE >= 1 )THEN

      !$OMP PARALLEL DEFAULT(SHARED)
      !$OMP DO PRIVATE(ND,LF,LL,LP,L)
      DO ND=1,NDM
        LF=(ND-1)*LDMWET+1
        LL=MIN(LF+LDMWET-1,LAWET)
        DO LP=LF,LL
          L=LWET(LP)
          TVAR3W(L)=TSX(LEC(L))
          TVAR3S(L)=TSY(LNC(L))
          TVAR3E(L)=TBX(LEC(L))
          TVAR3N(L)=TBY(LNC(L))
        ENDDO
      ENDDO
      !$OMP END DO

      !$OMP DO PRIVATE(ND,LF,LL,LP,L,TAUBC,TAUBC2,UTMP,VTMP,CURANG,TAUB2,TMP)
      DO ND=1,NDM
        LF=(ND-1)*LDMWET+1
        LL=MIN(LF+LDMWET-1,LAWET)
        DO LP=LF,LL
          L=LWET(LP)
          IF( LWVMASK(L) )THEN
            TAUBC2 = (RSSBCE(L)*TVAR3E(L)+RSSBCW(L)*TBX(L))**2  +(RSSBCN(L)*TVAR3N(L)+RSSBCS(L)*TBY(L))**2
            TAUBC=0.5*SQRT(TAUBC2)   ! *** CURRENT ONLY
            CTAUC(L)=TAUBC
            UTMP=0.5*STCUV(L)*( U(LEC(L),KSZU(LEC(L))) + U(L,KSZU(L)) )+1.E-12
            VTMP=0.5*STCUV(L)*( V(LN ,KSZV(LN) ) + V(L,KSZV(L)) )
            CURANG=ATAN2(VTMP,UTMP)
            TAUB2=TAUBC*TAUBC +      (QQWV3(L)*QQWV3(L)) + 2.     *TAUBC*QQWV3(L)*COS(CURANG-WV(L).DIR)
            TAUB2=MAX(TAUB2,0.)              ! *** CURRENT & WAVE
            QQ(L,0 )   = CTURB2*SQRT(TAUB2)  ! *** CELL CENTERED TURBULENT INTENSITY DUE TO CURRENTS & WAVES

            QQ(L,KC)   = 0.5*CTURB2*SQRT((TVAR3W(L)+TSX(L))**2 + (TVAR3S(L)+TSY(L))**2)
            QQSQR(L,0) = SQRT(QQ(L,0))
          ELSE
            TMP = ( RSSBCE(L)*TVAR3E(L) + RSSBCW(L)*TBX(L) )**2 + ( RSSBCN(L)*TVAR3N(L) + RSSBCS(L)*TBY(L) )**2
            QQ(L,0 ) = 0.5*CTURB2*SQRT(TMP)
            !QQ(L,0 ) = 0.5*CTURB2*SQRT( (TVAR3E(L)+TBX(L))**2 + (TVAR3N(L)+TBY(L))**2 )

            TMP = ( RSSBCE(L)*TVAR3W(L) + RSSBCW(L)*TSX(L) )**2 + ( RSSBCN(L)*TVAR3S(L) + RSSBCS(L)*TSY(L) )**2
            QQ(L,KC) = 0.5*CTURB2*SQRT(TMP)
            !QQ(L,KC) = 0.5*CTURB2*SQRT( (TVAR3W(L)+TSX(L))**2 + (TVAR3S(L)+TSY(L))**2 )

            QQSQR(L,0)=SQRT(QQ(L,0))
          ENDIF
        ENDDO
      ENDDO
      !$OMP END DO
      !$OMP END PARALLEL
    ENDIF

    !**********************************************************************C
    !
    ! *** CALCULATE TURBULENT INTENSITY SQUARED
    !
    IF( KC > 1 )THEN
      CALL CALQQ1 (ISTL)
    ENDIF
    TQQQ=TQQQ+(DSTIME(0)-TTDS)

    !**********************************************************************C
    ! *** CALCULATE MEAN MASS TRANSPORT FIELD
    IF( ISSSMMT /= 2 )THEN
      IF( ISICM >= 1 )THEN
        NTMP=MOD(N,2)
        IF( ISTL == 3 .AND. NTMP == 0 ) CALL CALMMT
      ENDIF
    ENDIF

    !**********************************************************************C
    !
    ! *** HYDRODYNAMIC CALCULATIONS FOR THIS TIME STEP ARE COMPLETED
    ! *** IF NCTBC EQ NTSTBC APPLY TRAPEZOIDAL CORRECTION
    !
    !----------------------------------------------------------------------C
    IF( NCTBC == NTSTBC )THEN
      NCTBC=0
      ISTL=2
      DELT=DT          ! *** NOT USED IN HDMT BUT INDICATIVE
      DELTD2=0.5*DT
      DZDDELT=DZ/DELT
      ROLD=0.5
      RNEW=0.5
      GOTO 500
    ELSE
      NCTBC=NCTBC+1
      ISTL=3
      DELT=DT2         ! *** NOT USED IN HDMT BUT INDICATIVE
      DELTD2=DT
      DZDDELT=DZ/DELT
      ROLD=0.
      RNEW=1.
    ENDIF

    !**********************************************************************C
    !
    ! *** WRITE TO TIME SERIES FILES
    !
    CTIM=DT*FLOAT(N)+TCON*TBEGIN
    CTIM=CTIM/TCON

    ICALLTP=0
    IF( ISTMSR >= 1 )THEN
      IF( NCTMSR >= NWTMSR )THEN
        CALL TMSR
        ICALLTP=1
        NCTMSR=1
      ELSE
        NCTMSR=NCTMSR+1
      ENDIF
    ENDIF

    !**********************************************************************C
    ! *** OUTPUT ZERO DIMENSION VOLUME BALANCE
    IF( ISDRY >= 1 .AND. ICALLTP == 1 .AND. DEBUG )THEN
      OPEN(1,FILE=OUTDIR//'ZVOLBAL.OUT',POSITION='APPEND',STATUS='UNKNOWN')
      DO LS=1,LORMAX
        IF( VOLZERD >= VOLSEL(LS) .AND. VOLZERD < VOLSEL(LS+1) )THEN
          WTM=VOLSEL(LS+1)-VOLZERD
          WTMP=VOLZERD-VOLSEL(LS)
          DELVOL=VOLSEL(LS+1)-VOLSEL(LS)
          WTM=WTM/DELVOL
          WTMP=WTMP/DELVOL
          SELZERD=WTM*BELSURF(LS)+WTMP*BELSURF(LS+1)
          ASFZERD=WTM*ASURFEL(LS)+WTMP*ASURFEL(LS+1)
        ENDIF
      ENDDO
      CTIM=(DT*FLOAT(N)+TCON*TBEGIN)/TCTMSR
      WRITE(1,5304)CTIM,SELZERD,ASFZERD,VOLZERD,VETZERD
      CLOSE(1)
     5304 FORMAT(2X,F10.4,2X,F10.5,3(2X,E12.4))
    ENDIF
    ICALLTP=0

    !**********************************************************************C
    ! *** CALCULATE MEAN MASS TRANSPORT FIELD
    IF( ISSSMMT /= 2 .AND. NTSMMT > 0 )THEN
      IF( ISICM == 0 ) CALL CALMMT
    ENDIF

    !**********************************************************************C
    !
    ! *** ADVANCE NEUTRALLY BUOYANT PARTICLE DRIFTER TRAJECTORIES
    !
    IF( ISPD >= 2 )THEN
      IF( TIMEDAY >= LA_BEGTI0 .AND. TIMEDAY <= LA_ENDTI0 )THEN
        TTDS=DSTIME(0)
        CALL DRIFTERC
        TLRPD=TLRPD+(DSTIME(0)-TTDS)
      ENDIF
    ENDIF

    !**********************************************************************C
    !
    ! *** CALCULATE VOLUME MASS, MOMENTUM AND ENERGY BALANCES
    !
    IF( ISBAL >= 1 )THEN
      CALL CALBAL5
      NTMP=MOD(N,2)
      IF( NTMP == 0 )THEN
        CALL CBALEV5
      ELSE
        CALL CBALOD5
      ENDIF
    ENDIF

    !   SEDIMENT BUDGET CALCULATION     (DLK 10/15)
    IF( ISSBAL >= 1 )THEN
      CALL BUDGET5
    ENDIF

    !**********************************************************************C
    ! *** PERFORM AN M2 TIDE HARMONIC ANALYSIS EVERY 2 M2 PERIODS
    IF( ISHTA == 1 ) CALL CALHTA

    !**********************************************************************C
    ! *** CALCULATE DISPERSION COEFFICIENTS
    IF( N >= NDISP .AND. NCTBC == 1 )THEN
      IF( ISDISP == 2 ) CALL CALDISP2
      IF( ISDISP == 3 ) CALL CALDISP3
    ENDIF

    !**********************************************************************C
    ! *** PERFORM LEAST SQUARES HARMONIC ANALYSIS AT SELECTED LOCATIONS
    IF( ISLSHA == 1 .AND. TIMESEC >= TIMEHARM )THEN
      CALL LSQHARM
      TIMEHARM = TIMEHARM + 300.
    ENDIF

  !**********************************************************************!
    ! *** WRITE TO TIME VARYING GRAPHICS FILES
    IF( HFREOUT == 1 )THEN
      DO NS=1,NSUBSET
        DEL = ABS(84600*(TIMEDAY-HFREDAY(NS)))
        IF( DEL <= DELT .AND. TIMEDAY <= HFREDAYEN(NS) )THEN
          CALL HFREHYOUT(0,NS)
          CALL HFREWCOUT(0,NS)
          CALL HFREWQOUT(0,NS)
          CALL HFRERPEMOUT(0,NS)
          HFREDAY(NS) = HFREDAY(NS) + HFREMIN(NS)/1440
        ENDIF
      ENDDO
    ENDIF

#ifdef NCOUT
    ! ** NETCDF OUTPUT
    IF (NCDFOUT > 0) THEN
      IF( TIMEDAY >= SNAPSHOTS(NSNAPSHOTS) .AND. (TIMEDAY >= TBEGNCDF .AND. TIMEDAY <= TENDNCDF )) THEN
        CALL NETCDF_WRITE(NC_ID)
      ELSEIF (TIMEDAY > TENDNCDF ) THEN
        CALL NC_CLOSE_FILE(NC_ID)
      ENDIF
    ENDIF
#endif
    !**********************************************************************C
    ! *** WRITE EFDC EXPLORER FORMAT OUTPUT
    IF( ISPPH == 1 )THEN
      IF( TIMEDAY >= SNAPSHOTS(NSNAPSHOTS) )THEN
        CALL EE_LINKAGE(0)
      ENDIF
    ENDIF
    IF( TIMEDAY >= SNAPSHOTS(NSNAPSHOTS) )THEN
      NSNAPSHOTS=NSNAPSHOTS+1
    ENDIF

    !**********************************************************************C
    ! *** WRITE TO TIME VARYING 3D HDF GRAPHICS FILES
    IF( N == NC3DO .AND. IS3DO == 1 )THEN
      CALL OUT3D
      NC3DO=NC3DO+(NTSPTC/NP3DO)
    ENDIF

    !**********************************************************************C
    ! *** WRITE RESTART FILE EVERY ISRESTO M2 REFERENCE PERIODS
    IF( ISRESTO >= 1 )THEN
      IF( TIMEDAY >= TIMELAST )THEN
        CALL RESTOUT(0)
        IF( ISTRAN(8) >= 1 )THEN
          IF( IWQRST == 1 ) CALL WQWCRST
          IF( IWQBEN == 1 ) CALL WQSDRST
          IF( ISRPEM > 0  ) CALL WQRPEMRST
        ENDIF
        TIMELAST = TIMEDAY + TIMERST
      ENDIF
    ENDIF

    !**********************************************************************C
    ! *** RECORD TIME

    ! *** DTIME AND FLUSH ARE SUPPORTED ON SUN SYSTEMS, BUT MAY NOT BE
    ! *** SUPPORTED ON OTHER SYSTEMS.
    !
    IF( NTIMER == NTSPTC )THEN
      ! *** EE BEGIN BLOCK
      CALL TIMELOG(N,TIMEDAY,OUTDIR)
      ! *** EE END BLOCK
      NTIMER=1
    ELSE
      NTIMER=NTIMER+1
    ENDIF

    !**********************************************************************C
    IF( ISHOW > 0 ) CALL SHOWVAL

    !**********************************************************************C
#ifdef _WIN
    IF( KEY_PRESSED() )THEN
      IF( ISEXIT())GOTO 1001
    ENDIF
#endif

  1000 CONTINUE

  !**********************************************************************C
  !**********************************************************************C
  !
  ! *** TIME LOOP COMPLETED
  !
  1001 THDMT=THDMT+(DSTIME(0)-T1TMP)

  !**********************************************************************C
  !
  2000 CONTINUE

  !**********************************************************************C

  ! *** WRITE RESTART FILE
  IF( ABS(ISRESTO) > 0 .AND. TIMEDAY > TIMELAST-TIMERST*0.5 )THEN
    WRITE(6,'(A,F12.4)') 'FINAL RESTART FILE: ',TIMEDAY
    CALL RESTOUT(0)
    IF( ISTRAN(8) >= 1 )THEN
      IF( IWQRST == 1 ) CALL WQWCRST
      IF( IWQBEN == 1 ) CALL WQSDRST
      IF( ISRPEM > 0  ) CALL WQRPEMRST
    ENDIF
  ENDIF
  IF( ISRESTO == -2 )THEN
    CALL RESTMOD
  ENDIF

  !**********************************************************************C
  ! *** COMPLETE LEAST SQUARES HARMONIC ANALYSIS
  LSLSHA=1
  IF( ISLSHA == 1 ) CALL LSQHARM

  !**********************************************************************C
  ! *** OUTPUT COSMETIC VOLUME LOSSES FORM DRY CELLS
  IF( NDRYSTP < 0 )THEN
    OPEN(1,FILE=OUTDIR//'DRYLOSS.OUT')
    CLOSE(1,STATUS='DELETE')
    OPEN(1,FILE=OUTDIR//'DRYLOSS.OUT')

    WRITE(1,'(3A5,A14,A10)')'L','I','J','VOL WASTED','EQUIV HP'
    DO L=2,LA
      WRITE(1,1993)L,IL(L),JL(L),VDWASTE(L),VDWASTE(L)/DXYP(L)
    ENDDO
    1993 FORMAT(3I5,E14.6,F10.3)

    CLOSE(1)
  ENDIF

  !**********************************************************************C
  ! *** OUTPUT COURANT NUMBER DIAGNOSTICS
  IF( ISINWV == 1 .AND. DEBUG )THEN
    OPEN(1,FILE=OUTDIR//'CFLMAX.OUT')
    CLOSE(1,STATUS='DELETE')
    OPEN(1,FILE=OUTDIR//'CFLMAX.OUT')

    DO L=2,LA
      WRITE(1,1991)IL(L),JL(L),(CFLUUU(L,K),K=1,KC)
      WRITE(1,1992)(CFLVVV(L,K),K=1,KC)
      WRITE(1,1992)(CFLWWW(L,K),K=1,KC)
      WRITE(1,1992)(CFLCAC(L,K),K=1,KC)
    ENDDO

    CLOSE(1)
     1991 FORMAT(2I5,12F7.2)
     1992 FORMAT(10X,12F7.2)
  ENDIF

  !**********************************************************************C
  !
  ! *** OUTPUT FINAL FOOD CHAIN AVERAGING PERIOD
  IF( ISTRAN(5) >= 1 .AND. ISFDCH >= 1 )CALL FOODCHAIN(1)
#ifdef NCOUT
  IF (NCDFOUT > 0) CALL NC_CLOSE_FILE(NC_ID)
#endif
END


!     Last change:  HO   31 May 2000    2:26 am
!============================================================================
MODULE layer2
IMPLICIT NONE
PRIVATE
PUBLIC :: subband_normalization, bit_allocation, quantization, &
          initialize_table, table, layer2_table, nscfsi
REAL (KIND = 8) :: scale_factor(0:63), snr(0:17), a(17), b(17)
TYPE :: layer2_table
 INTEGER :: nsteps(0:17), nsample(0:17), nlength(0:17)
!
 INTEGER :: nband
 INTEGER :: nbal(32)
 INTEGER :: nbit(32, 0:15)
END TYPE layer2_table
TYPE (layer2_table) :: table
INTEGER, PARAMETER :: itransmission_pattern(5, 5) = &
RESHAPE( (/123, 122, 122, 133, 123, &
           113, 111, 111, 444, 113, &
           111, 111, 111, 333, 113, &
           222, 222, 222, 333, 123, &
           123, 122, 122, 133, 123  /), (/5, 5 /) )
INTEGER, PARAMETER :: iscale_factor_select_information(5, 5) = &
RESHAPE( (/0, 3, 3, 3, 0, &
           1, 2, 2, 2, 1, &
           2, 2, 2, 2, 1, &
           2, 2, 2, 2, 0, &
           0, 3, 3, 3, 0  /), (/5, 5/) )
INTEGER, PARAMETER :: nscfsi(0:3) = (/3, 2, 1, 2/)
CONTAINS
!-------------------------------------------------------------------
SUBROUTINE initialize_table(itable)
IMPLICIT NONE
INTEGER, INTENT(IN) :: itable
table%nsteps(0:17)  = (/0, 3, 5, 7, 9, 15, 31, 63, 127, 255, 511, 1023, 2047, 4095, 8191, 16383, 32767, 65535/)
table%nsample(0:17) = (/1, 3, 3, 1, 3,  1,  1,  1,   1,   1,   1,    1,    1,    1,    1,     1,     1,     1/)
table%nlength(0:17) = (/0, 5, 7, 3,10,  4,  5,  6,   7,   8,   9,   10,   11,   12,   13,    14,    15,    16/)
SELECT CASE (itable)
 CASE (1)
  table%nband = 27
  table%nbal = (/4, 4, 4, 4, 4, 4, 4, 4, 4, 4, &
                 4, 3, 3, 3, 3, 3, 3, 3, 3, 3, &
                 3, 3, 3, 2, 2, 2, 2, 0, 0, 0, 0, 0/)
  table%nbit( 1, :) = (/0, 1, 3,  5, 6, 7, 8,  9, 10, 11, 12, 13, 14, 15, 16, 17/)
  table%nbit( 2, :) = (/0, 1, 3,  5, 6, 7, 8,  9, 10, 11, 12, 13, 14, 15, 16, 17/)
  table%nbit( 3, :) = (/0, 1, 3,  5, 6, 7, 8,  9, 10, 11, 12, 13, 14, 15, 16, 17/)
  table%nbit( 4, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit( 5, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit( 6, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit( 7, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit( 8, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit( 9, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit(10, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit(11, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit(12, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(13, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(14, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(15, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(16, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(17, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(18, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(19, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(20, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(21, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(22, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(23, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(24, :) = (/0, 1, 2, 17, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(25, :) = (/0, 1, 2, 17, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(26, :) = (/0, 1, 2, 17, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(27, :) = (/0, 1, 2, 17, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(28, :) = (/0, 0, 0,  0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(29, :) = (/0, 0, 0,  0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(30, :) = (/0, 0, 0,  0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(31, :) = (/0, 0, 0,  0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(32, :) = (/0, 0, 0,  0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
 CASE (2)
  table%nband = 30
  table%nbal = (/4, 4, 4, 4, 4, 4, 4, 4, 4, 4, &
                 4, 3, 3, 3, 3, 3, 3, 3, 3, 3, &
                 3, 3, 3, 2, 2, 2, 2, 2, 2, 2, 0, 0/)
  table%nbit( 1, :) = (/0, 1, 3,  5, 6, 7, 8,  9, 10, 11, 12, 13, 14, 15, 16, 17/)
  table%nbit( 2, :) = (/0, 1, 3,  5, 6, 7, 8,  9, 10, 11, 12, 13, 14, 15, 16, 17/)
  table%nbit( 3, :) = (/0, 1, 3,  5, 6, 7, 8,  9, 10, 11, 12, 13, 14, 15, 16, 17/)
  table%nbit( 4, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit( 5, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit( 6, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit( 7, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit( 8, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit( 9, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit(10, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit(11, :) = (/0, 1, 2,  3, 4, 5, 6,  7,  8,  9, 10, 11, 12, 13, 14, 17/)
  table%nbit(12, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(13, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(14, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(15, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(16, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(17, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(18, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(19, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(20, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(21, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(22, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(23, :) = (/0, 1, 2,  3, 4, 5, 6, 17,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(24, :) = (/0, 1, 2, 17, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(25, :) = (/0, 1, 2, 17, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(26, :) = (/0, 1, 2, 17, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(27, :) = (/0, 1, 2, 17, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(28, :) = (/0, 1, 2, 17, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(29, :) = (/0, 1, 2, 17, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(30, :) = (/0, 1, 2, 17, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(31, :) = (/0, 0, 0,  0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(32, :) = (/0, 0, 0,  0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0,  0,  0/)
 CASE (3)
  table%nband = 8
  table%nbal = (/4, 4, 3, 3, 3, 3, 3, 3, 0, 0, &
                 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
                 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/)
  table%nbit( 1, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16/)
  table%nbit( 2, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16/)
  table%nbit( 3, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 4, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 5, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 6, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 7, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 8, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 9, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(10, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(11, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(12, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(13, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(14, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(15, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(16, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(17, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(18, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(19, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(20, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(21, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(22, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(23, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(24, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(25, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(26, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(27, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(28, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(29, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(30, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(31, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(32, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
 CASE (4)
  table%nband = 12
  table%nbal = (/4, 4, 3, 3, 3, 3, 3, 3, 3, 3, &
                 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, &
                 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/)
  table%nbit( 1, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16/)
  table%nbit( 2, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16/)
  table%nbit( 3, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 4, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 5, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 6, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 7, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 8, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit( 9, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(10, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(11, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(12, :) = (/0, 1, 2, 4, 5, 6, 7, 8, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(13, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(14, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(15, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(16, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(17, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(18, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(19, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(20, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(21, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(22, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(23, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(24, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(25, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(26, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(27, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(28, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(29, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(30, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(31, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
  table%nbit(32, :) = (/0, 0, 0, 0, 0, 0, 0, 0, 0,  0,  0,  0,  0,  0,  0,  0/)
 CASE DEFAULT
  STOP 'input error in initalize_table'
END SELECT
RETURN
END SUBROUTINE initialize_table
!-------------------------------------------------------------------
SUBROUTINE initialize_scalefactor()
IMPLICIT NONE
INTEGER :: i
DO i = 0, 2**6 - 1
 scale_factor(i) = 1.0d-14 * ANINT( 1.0d14 * 2.0d0**( -REAL(i - 1, KIND = 8) / 3.0d0 )  )
END DO
RETURN
END SUBROUTINE initialize_scalefactor
!-------------------------------------------------------------------
SUBROUTINE subband_normalization(subband, iscale_factor, iscfsi)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN OUT) :: subband(:, :, :)
INTEGER        , INTENT(   OUT) :: iscale_factor(:, :, :)
INTEGER        , INTENT(   OUT) :: iscfsi(:, :)
INTEGER :: i, i0, i1, iband
LOGICAL :: qfirst = .TRUE.
IF (qfirst) THEN
 qfirst = .FALSE.
 CALL initialize_scalefactor()
END IF
CALL get_scale_factor(subband, iscale_factor)
CALL scale_factor_select_information(iscale_factor, iscfsi)
DO i = 1, 3
 i0 = 12 * (i - 1) + 1
 i1 = 12 *  i
 DO iband = 1, table%nband
  subband(iband, 1, i0:i1) = subband(iband, 1, i0:i1) / scale_factor(iscale_factor(iband, 1, i))
  subband(iband, 2, i0:i1) = subband(iband, 2, i0:i1) / scale_factor(iscale_factor(iband, 2, i))
 END DO
END DO
RETURN
END SUBROUTINE subband_normalization
!-------------------------------------------------------------------
SUBROUTINE get_scale_factor(subband, iscale_factor)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN ) :: subband(:, :, :)
INTEGER        , INTENT(OUT) :: iscale_factor(:, :, :)
REAL (KIND = 8) :: subband_max(1)
INTEGER :: i, i0, i1, ichannel, iband, k
DO i = 1, 3
 i0 = 12 * (i - 1) + 1
 i1 = 12 *  i
 DO ichannel = 1, SIZE(subband, 2)
  DO iband = 1, 32
   subband_max = MAXVAL( ABS( subband(iband, ichannel, i0:i1) ) )
   DO k = 62, 0, -1
    IF ( subband_max(1) < scale_factor(k) ) THEN
     iscale_factor(iband, ichannel, i) = k
     EXIT
    END IF
   END DO
  END DO
 END DO
END DO
RETURN
END SUBROUTINE get_scale_factor
!-------------------------------------------------------------------
SUBROUTINE scale_factor_select_information(iscale_factor, iscfsi)
IMPLICIT NONE
INTEGER, INTENT(IN OUT) :: iscale_factor(:, :, :)
INTEGER, INTENT(   OUT) :: iscfsi(:, :)
INTEGER :: iband, ichannel, mscf1, mscf2, iclass1, iclass2, ipattern
DO ichannel = 1, SIZE(iscfsi, 2)
 DO iband = 1, 32
  mscf1 = iscale_factor(iband, ichannel, 1) - iscale_factor(iband, ichannel, 2)
  mscf2 = iscale_factor(iband, ichannel, 2) - iscale_factor(iband, ichannel, 3)
  iclass1 = iget_class(mscf1)
  iclass2 = iget_class(mscf2)
  ipattern = itransmission_pattern(iclass2, iclass1)
  CALL set_scale(iscale_factor(iband, ichannel, :), ipattern)
  iscfsi(iband, ichannel) = iscale_factor_select_information(iclass2, iclass1)
 END DO
END DO
RETURN
END SUBROUTINE scale_factor_select_information
!-------------------------------------------------------------------
FUNCTION iget_class(m) RESULT(ires)
IMPLICIT NONE
INTEGER, INTENT(IN) :: m
INTEGER :: ires
SELECT CASE (m)
 CASE (:-3)
  ires = 1
 CASE (-2:-1)
  ires = 2
 CASE (0)
  ires = 3
 CASE (1:2)
  ires = 4
 CASE (3:)
  ires = 5
END SELECT
RETURN
END FUNCTION iget_class
!-------------------------------------------------------------------
SUBROUTINE set_scale(iscale, ipattern)
IMPLICIT NONE
INTEGER, INTENT(IN OUT) :: iscale(:)
INTEGER, INTENT(IN    ) :: ipattern
SELECT CASE (ipattern)
 CASE (123)
  CONTINUE
 CASE (122)
  iscale(3) = iscale(2)
 CASE (133)
  iscale(2) = iscale(3)
 CASE (113)
  iscale(2) = iscale(1)
 CASE (111)
  iscale(2) = iscale(1)
  iscale(3) = iscale(1)
 CASE (222)
  iscale(1) = iscale(2)
  iscale(3) = iscale(2)
 CASE (333)
  iscale(1) = iscale(3)
  iscale(2) = iscale(3)
 CASE (444)
  iscale(1) = MIN( iscale(1), iscale(2), iscale(3) )
  iscale(2) = iscale(1)
  iscale(3) = iscale(1)
 CASE DEFAULT
  STOP 'undefined transmission pattern: set_scale'
END SELECT
RETURN
END SUBROUTINE set_scale
!-------------------------------------------------------------------
SUBROUTINE initialize_snr()
IMPLICIT NONE
snr( 0) =  0.00d0 !  0 bit
snr( 1) =  7.00d0 !  2 bit
snr( 2) = 11.00d0 !  2.59 bit log2(6)
snr( 3) = 16.00d0 !  3 bit
snr( 4) = 20.84d0 !  3.32 bit log2(10)
snr( 5) = 25.28d0 !  4 bit
snr( 6) = 31.59d0 !  5 bit
snr( 7) = 37.75d0 !  6 bit
snr( 8) = 43.84d0 !  7 bit
snr( 9) = 49.89d0 !  8 bit
snr(10) = 55.93d0 !  9 bit
snr(11) = 61.96d0 ! 10 bit
snr(12) = 67.98d0 ! 11 bit
snr(13) = 74.01d0 ! 12 bit
snr(14) = 80.03d0 ! 13 bit
snr(15) = 86.05d0 ! 14 bit
snr(16) = 92.01d0 ! 15 bit
snr(17) = 98.01d0 ! 16 bit
RETURN
END SUBROUTINE initialize_snr
!-------------------------------------------------------------------
SUBROUTINE bit_allocation(smr, iscfsi, ialloc_bits, itot_bits, max_bits)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN    ) :: smr(:, :)
INTEGER        , INTENT(IN    ) :: max_bits, iscfsi(:, :)
INTEGER        , INTENT(   OUT) :: ialloc_bits(:, :)
INTEGER        , INTENT(IN OUT) :: itot_bits
INTEGER :: ireq_bits(32, 2)
LOGICAL :: qfirst = .TRUE.
INTEGER :: iband, max_pos(2), k, n0, n1
REAL(KIND = 8) :: amnr(32, 2)
IF (qfirst) THEN
 qfirst = .FALSE.
 CALL initialize_snr()
END IF
ialloc_bits = 0
amnr = smr - snr(0)
ireq_bits = 999999 ! large number
DO iband = 1, table%nband
 ireq_bits(iband, :) = 2 & ! scfsi
                     + 6 * nscfsi(iscfsi(iband, :)) & ! scale_factor
                     + 3 / table%nsample(1) * table%nlength(1) * 12 ! data
END DO
DO
 max_pos = MAXLOC(amnr, mask = ireq_bits < max_bits - itot_bits)
 IF ( max_pos(1) <= 0 .OR. max_pos(2) <= 0 ) EXIT
 IF ( amnr( max_pos(1), max_pos(2) ) < -200.0 ) EXIT
 itot_bits = itot_bits + ireq_bits( max_pos(1), max_pos(2) )
 k = ialloc_bits( max_pos(1), max_pos(2) )
 IF ( k == 2**table%nbal(max_pos(1)) - 2 ) THEN ! true ISO
  ireq_bits( max_pos(1), max_pos(2) ) = 999999  ! maximum allowed bits
 ELSE IF ( table%nbal(max_pos(1)) /= 4 .AND. k == 2**table%nbal(max_pos(1)) - 3 ) THEN ! don't use maximum bit_alloc in higher bands non-ISO
  ireq_bits( max_pos(1), max_pos(2) ) = 999999
 ELSE
  n0 = table%nbit(max_pos(1) , k    )
  n1 = table%nbit(max_pos(1) , k + 1)
  ireq_bits( max_pos(1), max_pos(2) ) = 3 / table%nsample(n1) * table%nlength(n1) * 12 &
                                      - 3 / table%nsample(n0) * table%nlength(n0) * 12
 END IF
 ialloc_bits( max_pos(1), max_pos(2) ) = k + 1
 amnr       ( max_pos(1), max_pos(2) ) = smr( max_pos(1), max_pos(2) ) - snr(k + 1)
END DO
RETURN
END SUBROUTINE bit_allocation
!-------------------------------------------------------------------
SUBROUTINE initialize_quantization()
IMPLICIT NONE
INTEGER :: i
b(1) = -1.0d-9 * ANINT( 1.0d9 / 2.0d0**2.0d0 )
a(1) =  1.0d0 + b(1)
b(2) = -1.0d-9 * ANINT( 3.0d9 / 8.0d0 )
a(2) =  1.0d0 + b(2)
b(3) = -1.0d-9 * ANINT( 1.0d9 / 2.0d0**3.0d0 )
a(3) =  1.0d0 + b(3)
b(4) = -1.0d-9 * ANINT( 7.0d9 / 16.0d0 )
a(4) =  1.0d0 + b(4)
DO i = 5, 17
 b(i) = -1.0d-9 * ANINT(1.0d9 / 2.0d0**REAL(i - 1, KIND = 8))
 a(i) =  1.0d0 + b(i)
END DO
RETURN
END SUBROUTINE initialize_quantization
!-------------------------------------------------------------------
SUBROUTINE quantization(ialloc_bits, subband, isubband)
IMPLICIT NONE
INTEGER        , INTENT(IN ) :: ialloc_bits(:, :)
REAL (KIND = 8), INTENT(IN ) ::  subband(:, :, :)
INTEGER        , INTENT(OUT) :: isubband(:, :, :)
INTEGER :: ichannel, iband, msb, k, i, j, j0, j1
INTEGER, PARAMETER :: imsb(0:17) = (/0, 1, 2, 2, 3, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 /)
LOGICAL :: qfirst = .TRUE.
REAL(KIND = 8) :: s(12)
IF (qfirst) THEN
 qfirst = .FALSE.
 CALL initialize_quantization()
END IF
DO ichannel = 1, SIZE(subband, 2)
 DO iband = 1, table%nband
  k = table%nbit(iband, ialloc_bits(iband, ichannel))
  msb = 2**imsb(k)
  IF (k /= 0) THEN
   DO j = 1, 3
    j0 = 12 * (j - 1) + 1
    j1 = 12 * j
    s = a(k) * subband(iband, ichannel, j0:j1) + b(k)
    DO i = 1, 12
     IF (s(i) >= 0.0) THEN
      isubband(iband, ichannel, j0 - 1 + i) = INT( s(i) * REAL(msb, KIND = 8) ) + msb
     ELSE
      isubband(iband, ichannel, j0 - 1 + i) = INT( (s(i) + 1.0d0) * REAL(msb, KIND = 8) )
     END IF
    END DO
   END DO
  ELSE
   isubband(iband, ichannel, :) = 0
  END IF
 END DO
END DO
RETURN
END SUBROUTINE quantization
!-------------------------------------------------------------------
END MODULE layer2


      subroutine cdsld

      implicit double precision (a-h,o-z)
      save
      common /print/ iprint
      common /atomco/ den(30), dq1(30), dfl(30), ws, nqn(30), nql(30),
     1                nk(30), nmax(30), nel(30), norb, norbco

      common /dira/ dv(251), dr(251), dp(251), dq(251), dpas, tets,
     1              z, nstop, nes, np, nuc
      common /deux/ dvn(251), dvf(251), d(251), dc(251), dgc(251,30),
     1 dpc(251,30)

c titre = identification of the wave functions  s,p*,p,........
      character*40 ttl
      character*2  titre
      common /char/ titre(30), ttl

c  -- This read commented out to make input easier, not used for
c     PHASE calculations
      irm  = 0
      ins  = 0
      npun = 0
      nmfg = 0
      nmrk = 0
c     read (5,10) irm,ins,npun,nmfg,nmrk
   10 format (8i3)

c valeurs moyennes de r**j  if irm non-zero
c tabulation of the wave functions if ins non-zero
c the potential multiplied by r is perfore if npun non-zero
      if (irm.eq.0) go to 200
      if (iprint .ge. 5)  write(16,20) ttl
   20 format (1h1,40x,a40,/)
   30 read (5,10) j,l,n1,l1,j1,n2,l2,j2
      if (l.eq.0) go to 200

c valeur moyenne of (p1*p2+q1*q2)*r**j  if l positive
c valeur moyenne of (p1*q2+p2*q1)*r**j  if l negative
      if (n1.gt.0) go to 40
      if (((n1+1)*(n1+2)).ne.0) go to 60
      i1=1
      i2=1
      go to 80
   40 i1=0
      i2=0
      do 50 i=1,norb
      if (nqn(i).eq.n1.and.nql(i).eq.l1.and.(j1-1).eq.(-nk(i)/iabs(nk(i)
     1 ))) i1=i
      if (nqn(i).eq.n2.and.nql(i).eq.l2.and.(j2-1).eq.(-nk(i)/iabs(nk(i)
     1 ))) i2=i
   50 continue
      if (i1.ne.0.and.i2.ne.0) go to 80
   60 if (iprint .ge. 5)  write(16,70) j,l,n1,l1,j1,n2,l2,j2
   70 format (1h0,'    error for the card     ',8i3)
      go to 30
   80 dval=dfl(i1)+dfl(i2)
      if ((dval+j).gt.-1.0) go to 90
      if (n1) 170,170,60
   90 im=nmax(i1)
      if (nmax(i2).lt.im) im=nmax(i2)
      if (l.lt.0) go to 110
      do 100 i=1,im
      dv(i)=dgc(i,i1)*dgc(i,i2)
  100 dq(i)=dpc(i,i1)*dpc(i,i2)
      go to 130
  110 do 120 i=1,im
      dv(i)=dgc(i,i1)*dpc(i,i2)
  120 dq(i)=dgc(i,i2)*dpc(i,i1)
  130 call somm (dr,dv,dq,dpas,dval,j,im)
      if (l.lt.0) go to 150
      if (iprint .ge. 5)  write(16,140) j,nqn(i1),titre(i1),nqn(i2),
     1                                   titre(i2),dval
  140 format (24x,'(p1p2+q1q2)r**',i2,' for  ',i1,a2,i3,a2,5x,'=',1pe14.
     1 7,/)
      go to 170
  150 if (iprint .ge. 5)  write(16,160) j,nqn(i1),titre(i1),nqn(i2),
     1                                   titre(i2),dval
  160 format (24x,'(p1q2+q1p2)r**',i2,' for  ',i1,a2,i3,a2,5x,'=',1pe14.
     1 7,/)
  170 if (n1+1) 190,180,30
  180 i1=i1+1
      i2=i1
      if (i1-norb) 80,80,30
  190 i2=i2+1
      if (i2-norb) 80,80,180
  200 if (ins.eq.0) go to 260
      do 250 i=1,norb,3
      j=i+2
      if (j.gt.norb) j=norb
      im=0
      do 210 l=i,j
      if (nmax(l).gt.im) im=nmax(l)
  210 continue
      do 230 k=1,im
      if (((k-1)*(k-48*(k/48))).ne.0) go to 230
      if (iprint .ge. 5)  write(16,20) ttl
      if (iprint .ge. 5)  write(16,220) (nqn(l),titre(l),nqn(l),
     1                                     titre(l),l=i,j)
  220 format (9x,'r',14x,3(i1,a2,'g.c.',i11,a2,'p.c.',10x))
  230 if (iprint .ge. 5)  write(16,240) dr(k),
     1                                   (dgc(k,l),dpc(k,l),l=i,j)
  240 format (7(1pe17.7))
  250 continue
  260 if (npun.eq.0) go to 300
      do 270 i=1,np
  270 dp(i)=dvf(i)*dr(i)
c     write(8,280) ttl
  280 format (a40)
c     write(8,290) (dp(i),i=1,np)
  290 format (8f9.4)
  300 do 310 i=1,np
  310 d(i)=0.0
      nag=1
      if (nmfg.eq.0) go to 470
      if (iprint .ge. 5)  write(16,20)
      if (iprint .ge. 5)  write(16,320)
  320 format (/,30x,'integrales magnetiques directes et d echange'//)
  330 read (5,10) i1,i2,n1
      if (i1.le.0) go to 470
      if (i2.gt.0) go to 350
      if (((i2+1)*(i2+2)).ne.0) go to 340
      if (n1.le.0) n1=1
      i1=n1
      n1=i2
      i2=i1
      go to 360
  340 if (iprint .ge. 5)  write(16,70) i1,i2,n1
      go to 330
  350 if (i1.gt.norb.or.i2.gt.norb) go to 340
      n1=1
  360 j1=2*iabs(nk(i1))-1
      j2=2*iabs(nk(i2))-1
      kma=min0(j1,j2)
      nm=nmax(i2)
      do 380 j=1,kma,2
      call ykdir (i1,i1,j,nag)
      do 370 i=1,nm
  370 dp(i)=dq(i)*dgc(i,i2)*dpc(i,i2)
      dval=j+1
      call somm (dr,d,dp,dpas,dval,-1,nm)
  380 if (iprint .ge. 5)  write(16,390) j,nqn(i1),titre(i1),nqn(i2),
     1                                   titre(i2),dval
  390 format (20x,'fm',i2,' (',i1,a2,',',i1,a2,') =',1pe14.7)
      if (i1.eq.i2) go to 440
      j1=(iabs(1-2*nk(i1))-1)/2
      j2=(iabs(1-2*nk(i2))-1)/2
      kma=max0(nql(i1)+j2,nql(i2)+j1)
      j1=iabs(nql(i2)-j1)
      j2=iabs(nql(i1)-j2)
      kmi=min0(j1,j2)
      j1=kmi+nql(i1)+nql(i2)
      j1=j1-2*(j1/2)
      if (j1.eq.0) kmi=kmi+1
      nm=min0(nmax(i1),nmax(i2))
      do 420 j=kmi,kma,2
      call ykdir (i1,i2,j,nag)
      do 400 i=1,nm
      dp(i)=dq(i)*dgc(i,i1)*dpc(i,i2)
  400 dc(i)=dq(i)*dgc(i,i2)*dpc(i,i1)
      dval=j+1
      dvalp=dval
      dvalm=dval
      call somm (dr,d,dp,dpas,dvalp,-1,nm)
      call somm (dr,d,dc,dpas,dval,-1,nm)
      call ykdir (i2,i1,j,nag)
      do 410 i=1,nm
  410 dp(i)=dq(i)*dgc(i,i2)*dpc(i,i1)
      call somm (dr,d,dp,dpas,dvalm,-1,nm)
  420 if (iprint .ge. 5)  write(16,430) j,nqn(i1),titre(i1),nqn(i2),
     1                                   titre(i2),dvalm,dval,dvalp
  430 format (' gm',i2,' (',i1,a2,',',i1,a2,')',5x,'(-1)=',1pe14.7,5x,'(
     10)=',1pe14.7,5x,'(+1)=',1pe14.7)
  440 if (n1+1) 460,450,330
  450 i1=i1+1
      i2=i1
      if (i1-norb) 360,360,330
  460 i2=i2+1
      if (i2-norb) 360,360,450
  470 if (nmrk.eq.0) go to 530
      if (iprint .ge. 5)  write(16,20)
      if (iprint .ge. 5)  write(16,480)
  480 format (/,20x,'integrales magnetiques rk=integrale de p1(1)*q2(1)*
     1uk(1,2)*p3(2)*q4(2)'//)
  490 read (5,10) i1,i2,i3,i4,k
      if (i1.le.0) go to 530
      if (i1.le.norb.and.i2.gt.0.and.i2.le.norb.and.i3.gt.0.and.i3.le
     1 .norb.and.i4.gt.0.and.i4.le.norb.and.k.ge.0) go to 500
      if (iprint .ge. 5)  write(16,70) i1,i2,i3,i4,k
      go to 490
  500 call ykdir (i1,i2,k,nag)
      do 510 i=1,np
  510 dp(i)=dq(i)*dgc(i,i3)*dpc(i,i4)
      dval=k+1
      call somm (dr,d,dp,dpas,dval,-1,np)
      if (iprint .ge. 5)  write(16,520) k,nqn(i1),titre(i1),nqn(i2),
     1              titre(i2),nqn(i3),titre(i3),nqn(i4),titre(i4),dval
  520 format (20x,'rm',i2,' (',i1,a2,',',i1,a2,',',i1,a2,',',i1,a2,') ='
     1 ,1pe14.7)
      go to 490
  530 return
      end