* This file contains the following subroutines, related to reading the
* extraterrestrial spectral irradiances:
*     rdetfl
*     read1
*     read2
*=============================================================================*

      SUBROUTINE rdetfl(nw,wl,f)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Read and re-grid extra-terrestrial flux data.                            =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NW     - INTEGER, number of specified intervals + 1 in working        (I)=*
*=           wavelength grid                                                 =*
*=  WL     - REAL, vector of lower limits of wavelength intervals in      (I)=*
*=           working wavelength grid                                         =*
*=  F      - REAL, spectral irradiance at the top of the atmosphere at    (O)=*
*=           each specified wavelength                                       =*
*-----------------------------------------------------------------------------*
*-----------------------------------------------------------------------------*
*= 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;  either version 2 of the license, or (at your   =*
*= option) any later version.                                                =*
*= The TUV package is distributed in the hope that it will be useful, but    =*
*= WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHANTIBI-  =*
*= LITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public     =*
*= License for more details.                                                 =*
*= To obtain a copy of the GNU General Public License, write to:             =*
*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.   =*
*-----------------------------------------------------------------------------*
*= To contact the authors, please mail to:                                   =*
*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA  or =*
*= send email to:  sasha@ucar.edu                                            =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE
      INCLUDE 'params'

      integer kdata
      parameter(kdata=900000)

* input: (wavelength grid)
      integer nw
      REAL wl(kw)
      integer iw

* output: (extra terrestrial solar flux)
      REAL f(kw)

* INTERNAL:

* work arrays for input data files:

      CHARACTER*40 fil
      REAL x1(kdata)
      REAL y1(kdata)
      integer nhead,n,i,ierr
      REAL dum

* data gridded onto wl(kw) grid:

      REAL yg1(kw)
      REAL yg2(kw)
      REAL yg3(kw)
      REAL yg4(kw)

      integer msun

*_______________________________________________________________________
* select desired extra-terrestrial solar irradiance, using msun:

*  1 =   extsol.flx:  De Luisi, JGR 80, 345-354, 1975
*                     280-400 nm, 1 nm steps.
*  2 =   lowsun3.flx:  Lowtran (John Bahr, priv. comm.)
*                      173.974-500000 nm, ca. 0.1 nm steps in UV-B
*  3 =   modtran1.flx:  Modtran (Gail Anderson, priv. comm.)
*                       200.55-949.40, 0.05 nm steps
*  4 =   nicolarv.flx:  wvl<300 nm from Nicolet, Plan. Sp. Sci., 29,  951-974, 1981.
*                       wvl>300 nm supplied by Thekaekera, Arvesen Applied Optics 8,
*                       11, 2215-2232, 1969 (also see Thekaekera, Applied Optics, 13,
*                       3, 518, 1974) but with corrections recommended by:
*                       Nicolet, Plan. Sp. Sci., 37, 1249-1289, 1989.
*                       270.0-299.0 nm in 0.5 nm steps
*                       299.6-340.0 nm in ca. 0.4 nm steps
*                       340.0-380.0 nm in ca. 0.2 nm steps
*                       380.0-470.0 nm in ca. 0.1 nm steps
*  5 =  solstice.flx:  From:   MX%"ROTTMAN@virgo.hao.ucar.edu" 12-OCT-1994 13:03:01.62
*                      Original data gave Wavelength in vacuum
*                      (Converted to wavelength in air using Pendorf, 1967, J. Opt. Soc. Am.)
*                      279.5 to 420 nm, 0.24 nm spectral resolution, approx 0.07 nm steps
*  6 =  suntoms.flx: (from TOMS CD-ROM).  280-340 nm, 0.05 nm steps.
*  7 =  neckel.flx:  H.Neckel and D.Labs, "The Solar Radiation Between 3300 and 12500 A",
*                    Solar Physics v.90, pp.205-258 (1984).
*                    1 nm between 330.5 and 529.5 nm
*                    2 nm between 631.0 and 709.0 nm
*                    5 nm between 872.5 and 1247.4 nm
*                    Units: must convert to W m-2 nm-1 from photons cm-2 s-1 nm-1
*  8 =  atlas3.flx:  ATLAS3-SUSIM 13 Nov 94 high resolution (0.15 nm FWHM)
*                    available by ftp from susim.nrl.navy.mil
*                    atlas3_1994_317_a.dat, downloaded 30 Sept 98.
*                    150-407.95 nm, in 0.05 nm steps
*                    (old version from Dianne Prinz through Jim Slusser)
*                    orig wavelengths in vac, correct here to air.
*  9 =  solstice.flx:  solstice 1991-1996, average
*                    119.5-420.5 nm in 1 nm steps

* 10 =  susim_hi.flx:  SUSIM SL2 high resolution
*                      120.5-400.0 in 0.05 nm intervals (0.15 nm resolution)
* 11 =  wmo85.flx: from WMO 1985 Atmospheric Ozone (report no. 16)
*                  on variable-size bins.  Original values are per bin, not
*                  per nm.
* 12 = combine susim_hi.flx for .lt. 350 nm, neckel.flx for .gt. 350 nm.
*
* 13 = combine
*     for wl(iw) .lt. 150.01                                susim_hi.flx
*     for wl(iw) .ge. 150.01 and wl(iw) .le. 400            atlas3.flx
*     for wl(iw) .gt. 400                                   Neckel & Labs
*
* 14 = combine
*     for wl(iw) .le. 350                                   susim_hi.flx
*     for wl(iw) .gt. 350                                   Neckel & Labs
*
* 15 = combine
*    for wl(iw) .lt. 150.01                                 susim_hi.flx
*    for wl(iw) .ge. 150.01 .and. wl(iw) .lt. 200.07        atlas3.flx
*    for wl(iw) .ge. 200.07 .and. wl(iw) .le. 1000.99       Chance and Kurucz 2010
*    for wl(iw) .gt. 1000.99                                Neckel & Labs

      msun = 15

* simple files are read and interpolated here in-line. Reading of
* more complex files may be done with longer code in a read#.f subroutine.

      IF (msun .EQ. 1) THEN
         fil = 'DATAE1/SUN/extsol.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 3
         n =121
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) x1(i),y1(i)
         ENDDO
         CLOSE (kin)
         CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
         CALL addpnt(x1,y1,kdata,n,0.,0.)
         CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
         CALL addpnt(x1,y1,kdata,n,1.e+38,0.)
         CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
         IF (ierr .NE. 0) THEN
            WRITE(*,*) ierr,fil
            STOP
         ENDIF
         DO iw = 1,nw-1
            f(iw) = yg1(iw)
         ENDDO

      ELSEIF (msun .EQ. 2) THEN
         fil = 'DATAE1/SUN/lowsun3.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 3
         n = 4327
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) x1(i),y1(i)
         ENDDO
         CLOSE (kin)
         CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
         CALL addpnt(x1,y1,kdata,n,0.,0.)
         CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
         CALL addpnt(x1,y1,kdata,n,1.e+38,0.)
         CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
         IF (ierr .NE. 0) THEN
            WRITE(*,*) ierr,fil
            STOP
         ENDIF
         DO iw = 1,nw-1
            f(iw) = yg1(iw)
         ENDDO

      ELSEIF (msun .EQ. 3) THEN
         fil = 'DATAE1/SUN/modtran1.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 6
         n = 14980
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) x1(i),y1(i)
         ENDDO
         CLOSE (kin)
         CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
         CALL addpnt(x1,y1,kdata,n,0.,0.)
         CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
         CALL addpnt(x1,y1,kdata,n,1.e+38,0.)
         CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
         IF (ierr .NE. 0) THEN
            WRITE(*,*) ierr,fil
            STOP
         ENDIF
         DO iw = 1,nw-1
            f(iw) = yg1(iw)
         ENDDO

      ELSEIF (msun .EQ. 4) THEN
         fil = 'DATAE1/SUN/nicolarv.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 8
         n = 1260
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) x1(i),y1(i)
         ENDDO
         CLOSE (kin)
         CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
         CALL addpnt(x1,y1,kdata,n,0.,0.)
         CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
         CALL addpnt(x1,y1,kdata,n,1.e+38,0.)
         CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
         IF (ierr .NE. 0) THEN
            WRITE(*,*) ierr,fil
            STOP
         ENDIF
         DO iw = 1,nw-1
            f(iw) = yg1(iw)
         ENDDO

      ELSEIF (msun .EQ. 5) THEN
* unofficial - do not use
         fil = 'DATAE2/SUN/solstice.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 11
         n = 2047
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) x1(i),y1(i)
         ENDDO
         CLOSE (kin)
         CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
         CALL addpnt(x1,y1,kdata,n,0.,0.)
         CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
         CALL addpnt(x1,y1,kdata,n,1.e+38,0.)
         CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
         IF (ierr .NE. 0) THEN
            WRITE(*,*) ierr,fil
            STOP
         ENDIF
         DO iw = 1,nw-1
            f(iw) = yg1(iw)
         ENDDO

      ELSEIF (msun .EQ. 6) THEN
* unofficial - do not use
         fil = 'DATAE2/SUN/suntoms.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 3
         n = 1200
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) x1(i),y1(i)
            y1(i) = y1(i)* 1.e-3
         ENDDO
         CLOSE (kin)
         CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
         CALL addpnt(x1,y1,kdata,n,0.,0.)
         CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
         CALL addpnt(x1,y1,kdata,n,1.e+38,0.)
         CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
         IF (ierr .NE. 0) THEN
            WRITE(*,*) ierr,fil
            STOP
         ENDIF
         DO iw = 1,nw-1
            f(iw) = yg1(iw)
         ENDDO

      ELSEIF (msun .EQ. 7) THEN
         fil = 'DATAE1/SUN/neckel.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 11
         n = 496
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) dum,y1(i)
            if (dum .lt. 630.0) x1(i) = dum-0.5
            if (dum .gt. 630.0 .and. dum .lt. 870.0) x1(i) = dum-1.0
            if (dum .gt. 870.0) x1(i) = dum-2.5
            y1(i) = y1(i) * 1.E4 * hc / (dum * 1.E-9)
         ENDDO
         CLOSE (kin)
         x1(n+1) = x1(n)+2.5
         do i = 1,n
            y1(i) = y1(i) * (x1(i+1)-x1(i))
         enddo
         call inter3(nw,wl,yg2,n+1,x1,y1,0)
         do iw = 1,nw-1
            yg1(iw) = yg1(iw) / (wl(iw+1)-wl(iw))
         enddo
         DO iw = 1,nw-1
            f(iw) = yg1(iw)
         ENDDO

      ELSEIF (msun .EQ. 8) THEN
         nhead = 5
         fil = 'DATAE1/SUN/atlas3_1994_317_a.dat'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 13
         n = 5160
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) x1(i),y1(i)
            y1(i) = y1(i) * 1.E-3
         ENDDO
         CLOSE (kin)
         CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
         CALL addpnt(x1,y1,kdata,n,0.,0.)
         CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
         CALL addpnt(x1,y1,kdata,n,1.e+38,0.)
         CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
         IF (ierr .NE. 0) THEN
            WRITE(*,*) ierr,fil
            STOP
         ENDIF
         DO iw = 1,nw-1
            f(iw) = yg1(iw)
         ENDDO

      ELSEIF (msun .EQ. 9) THEN
         fil = 'DATAE1/SUN/solstice.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 2
         n = 302
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) x1(i),y1(i)
         ENDDO
         CLOSE (kin)
         CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
         CALL addpnt(x1,y1,kdata,n,0.,0.)
         CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
         CALL addpnt(x1,y1,kdata,n,1.e+38,0.)
         CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
         IF (ierr .NE. 0) THEN
            WRITE(*,*) ierr,fil
            STOP
         ENDIF
         DO iw = 1,nw-1
            f(iw) = yg1(iw)
         ENDDO

      ELSEIF (msun .EQ. 10) THEN
         WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
         CALL read1(nw,wl,yg1)
         DO iw = 1,nw-1
            f(iw) = yg1(iw)
         ENDDO

      ELSEIF (msun .EQ. 11) THEN
         WRITE(kout,*) 'DATAE1/SUN/wmo85.flx'
         CALL read2(nw,wl,yg1)
         DO iw = 1,nw-1
            f(iw) = yg1(iw)
         ENDDO

      ELSEIF (msun .EQ. 12) THEN
         WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
         CALL read1(nw,wl,yg1)
         fil = 'DATAE1/SUN/neckel.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 11
         n = 496
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) dum,y1(i)
            if (dum .lt. 630.0) x1(i) = dum-0.5
            if (dum .gt. 630.0 .and. dum .lt. 870.0) x1(i) = dum-1.0
            if (dum .gt. 870.0) x1(i) = dum-2.5
            y1(i) = y1(i) * 1.E4 * hc / (dum * 1.E-9)
         ENDDO
         CLOSE (kin)
         x1(n+1) = x1(n)+2.5
         do i = 1,n
            y1(i) = y1(i) * (x1(i+1)-x1(i))
         enddo
         call inter3(nw,wl,yg2,n+1,x1,y1,0)
         do iw = 1,nw-1
            yg2(iw) = yg2(iw) / (wl(iw+1)-wl(iw))
         enddo

         DO iw = 1,nw-1
            IF (wl(iw) .GT. 350.) THEN
               f(iw) = yg2(iw)
            ELSE
               f(iw) = yg1(iw)
            ENDIF
         ENDDO

      ELSEIF (msun .EQ. 13) THEN

         WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
         CALL read1(nw,wl,yg1)

         nhead = 5
         fil = 'DATAE1/SUN/atlas3_1994_317_a.dat'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         n = 5160
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) x1(i),y1(i)
            y1(i) = y1(i) * 1.E-3
         ENDDO
         CLOSE (kin)
         CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
         CALL addpnt(x1,y1,kdata,n,0.,0.)
         CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
         CALL addpnt(x1,y1,kdata,n,1.e+38,0.)
         CALL inter2(nw,wl,yg2,n,x1,y1,ierr)
         IF (ierr .NE. 0) THEN
            WRITE(*,*) ierr,fil
            STOP
         ENDIF

         fil = 'DATAE1/SUN/neckel.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 11
         n = 496
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) dum,y1(i)
            if (dum .lt. 630.0) x1(i) = dum-0.5
            if (dum .gt. 630.0 .and. dum .lt. 870.0) x1(i) = dum-1.0
            if (dum .gt. 870.0) x1(i) = dum-2.5
            y1(i) = y1(i) * 1.E4 * hc / (dum * 1.E-9)
         ENDDO
         CLOSE (kin)

         x1(n+1) = x1(n)+2.5
         call inter4(nw,wl,yg3,n+1,x1,y1,0)

         DO iw = 1,nw-1

            IF (wl(iw) .LT. 150.01) THEN
               f(iw) = yg1(iw)
            ELSE IF ((wl(iw) .GE. 150.01) .AND. wl(iw) .LE. 400.) THEN
               f(iw) = yg2(iw)
            ELSE IF (wl(iw) .GT. 400.) THEN
               f(iw) = yg3(iw)
            ENDIF

         ENDDO

      ELSEIF (msun .EQ. 14) THEN

         WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
         CALL read1(nw,wl,yg1)

         fil = 'DATAE1/SUN/neckel.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 11
         n = 496
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) dum,y1(i)
            if (dum .lt. 630.0) x1(i) = dum-0.5
            if (dum .gt. 630.0 .and. dum .lt. 870.0) x1(i) = dum-1.0
            if (dum .gt. 870.0) x1(i) = dum-2.5
            y1(i) = y1(i) * 1.E4 * hc / (dum * 1.E-9)
         ENDDO
         CLOSE (kin)

         x1(n+1) = x1(n)+2.5
         call inter4(nw,wl,yg3,n+1,x1,y1,0)

         DO iw = 1,nw-1

            IF (wl(iw) .LE. 350.) THEN
               f(iw) = yg1(iw)
            ELSE
               f(iw) = yg3(iw)
            ENDIF

         ENDDO

      ELSEIF (msun .EQ. 15) THEN

         WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
         CALL read1(nw,wl,yg1)

         nhead = 5
         fil = 'DATAE1/SUN/atlas3_1994_317_a.dat'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         n = 5160
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) x1(i),y1(i)
            y1(i) = y1(i) * 1.E-3
         ENDDO
         CLOSE (kin)
         CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
         CALL addpnt(x1,y1,kdata,n,0.,0.)
         CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
         CALL addpnt(x1,y1,kdata,n,1.e+38,0.)
         CALL inter2(nw,wl,yg2,n,x1,y1,ierr)
         IF (ierr .NE. 0) THEN
            WRITE(*,*) ierr,fil
            STOP
         ENDIF

         fil = 'DATAE1/SUN/neckel.flx'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         nhead = 11
         n = 496
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) dum,y1(i)
            if (dum .lt. 630.0) x1(i) = dum-0.5
            if (dum .gt. 630.0 .and. dum .lt. 870.0) x1(i) = dum-1.0
            if (dum .gt. 870.0) x1(i) = dum-2.5
            y1(i) = y1(i) * 1.E4 * hc / (dum * 1.E-9)
         ENDDO
         CLOSE (kin)

         x1(n+1) = x1(n)+2.5
         call inter4(nw,wl,yg3,n+1,x1,y1,0)

         nhead = 8
         fil = 'DATAE1/SUN/sao2010.solref.converted'
         write(kout,*) fil
         OPEN(UNIT=kin,FILE=fil,STATUS='old')
         n = 80099-nhead
         DO i = 1,nhead
            READ(kin,*)
         ENDDO
         DO i = 1,n
            READ(kin,*) x1(i),dum,y1(i),dum
c            y1(i) = y1(i) * 1.E4 * hc / (x1(i) * 1.E-9)
         ENDDO
         CLOSE (kin)

         CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
         CALL addpnt(x1,y1,kdata,n,0.,0.)
         CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
         CALL addpnt(x1,y1,kdata,n,1.e+38,0.)
         CALL inter2(nw,wl,yg4,n,x1,y1,ierr)
         IF (ierr .NE. 0) THEN
            WRITE(*,*) ierr,fil
            STOP
         ENDIF

*    for wl(iw) .lt. 150.01                                 susim_hi.flx
*    for wl(iw) .ge. 150.01 .and. wl(iw) .lt. 200.07        atlas3.flx
*    for wl(iw) .ge. 200.07 .and. wl(iw) .le. 1000.99       Chance and Kurucz 2010
*    for wl(iw) .gt. 1000.99                                Neckel & Labs

         DO iw = 1,nw-1

            IF (wl(iw) .LT. 150.01) THEN
               f(iw) = yg1(iw)
            ELSE IF ((wl(iw) .GE. 150.01) .AND. wl(iw) .LT. 200.07) THEN
               f(iw) = yg2(iw)
            ELSE IF ((wl(iw) .GE. 200.07) .AND. wl(iw) .LT. 1000.99)THEN
               f(iw) = yg4(iw)
            ELSE IF (wl(iw) .GT. 1000.99) THEN
               f(iw) = yg3(iw)
            ENDIF

         ENDDO

      ENDIF

      RETURN
      END

*=============================================================================*

      SUBROUTINE read1(nw,wl,f)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Read extra-terrestrial flux data.  Re-grid data to match specified       =*
*=  working wavelength grid.                                                 =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NW     - INTEGER, number of specified intervals + 1 in working        (I)=*
*=           wavelength grid                                                 =*
*=  WL     - REAL, vector of lower limits of wavelength intervals in      (I)=*
*=           working wavelength grid                                         =*
*=  F      - REAL, spectral irradiance at the top of the atmosphere at    (O)=*
*=           each specified wavelength                                       =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE
      INCLUDE 'params'

* input: (wavelength grid)
      integer nw
      REAL wl(kw)

* output: (extra terrestrial solar flux)
      REAL f(kw)

* local:

      REAL lambda_hi(10000),irrad_hi(10000)
      REAL lambda
      integer ierr
      integer i,j,n
      CHARACTER*40 FIL

*_______________________________________________________________________

******* SUSIM irradiance
*_______________________________________________________________________
* VanHoosier, M. E., J.-D. F. Bartoe, G. E. Brueckner, and
* D. K. Prinz, Absolute solar spectral irradiance 120 nm -
* 400 nm (Results from the Solar Ultraviolet Spectral Irradiance
* Monitor - SUSIM- Experiment on board Spacelab 2),
* Astro. Lett. and Communications, 1988, vol. 27, pp. 163-168.
*     SUSIM SL2 high resolution (0.15nm) Solar Irridance data.
*     Irradiance values are given in milliwatts/m^2/nanomenters
*     and are listed at 0.05nm intervals.  The wavelength given is
*     the center wavelength of the 0.15nm triangular bandpass.
*     Normalized to 1 astronomical unit.
*  DATA for wavelengths > 350 nm are unreliable
* (Van Hoosier, personal communication, 1994).
*_______________________________________________________________________

** high resolution

      fil = 'DATAE1/SUN/susim_hi.flx'
      OPEN(UNIT=kin,FILE=fil,STATUS='old')
      DO 11,i = 1,7
         READ(kin,*)
   11 CONTINUE
      DO 12,i = 1,559
         READ(kin,*)lambda,(irrad_hi(10*(i-1)+j),j=1,10)
   12 CONTINUE
      CLOSE (kin)

* compute wavelengths, convert from mW to W

      n = 559*10
      DO 13,i = 1,n
         lambda_hi(i)=120.5+FLOAT(i-1)*.05
         irrad_hi(i) = irrad_hi(i)  /  1000.
   13 CONTINUE
*_______________________________________________________________________

      CALL addpnt(lambda_hi,irrad_hi,10000,n,lambda_hi(1)*(1.-deltax),
     >   0.)
      CALL addpnt(lambda_hi,irrad_hi,10000,n,0.,0.)
      CALL addpnt(lambda_hi,irrad_hi,10000,n,lambda_hi(n)*(1.+deltax),
     >   0.)
      CALL addpnt(lambda_hi,irrad_hi,10000,n,1.e38,0.)
      CALL inter2(nw,wl,f,n,lambda_hi,irrad_hi,ierr)
      IF (ierr .NE. 0) THEN
         WRITE(*,*) ierr,fil
         STOP
      ENDIF

      RETURN
      END

*=============================================================================*

      SUBROUTINE read2(nw,wl,f)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Read extra-terrestrial flux data.  Re-grid data to match specified       =*
*=  working wavelength grid.                                                 =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NW     - INTEGER, number of specified intervals + 1 in working        (I)=*
*=           wavelength grid                                                 =*
*=  WL     - REAL, vector of lower limits of wavelength intervals in      (I)=*
*=           working wavelength grid                                         =*
*=  F      - REAL, spectral irradiance at the top of the atmosphere at    (O)=*
*=           each specified wavelength                                       =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE
      INCLUDE 'params'

* input: (wavelength grid)
      integer nw
      REAL wl(kw)
      REAL yg(kw)

*
      integer iw

* output: (extra terrestrial solar flux)
      REAL f(kw)

* local:

      REAL x1(1000),y1(1000)
      REAL x2(1000)
      REAL x3(1000)
      integer i,n
      REAL DUM
      integer IDUM

*_______________________________________________________________________

*********WMO 85 irradiance

      OPEN(UNIT=kin,FILE='DATAE1/SUN/wmo85.flx',STATUS='old')
      DO 11,i = 1,3
         READ(kin,*)
   11 CONTINUE
      n = 158
      DO 12,i = 1,n
         READ(kin,*) idum,x1(i),x2(i),y1(i),dum,dum,dum
         x3(i) = 0.5 * (x1(i)+x2(i))

C average value needs to be calculated only if inter2 is
C used to interpolate onto wavelength grid (see below)
C        y1(i) =  y1(i) / (x2(i) - x1(i))

   12 CONTINUE
      CLOSE (kin)

      x1(n+1) = x2(n)

C inter2: INPUT : average value in each bin
C         OUTPUT: average value in each bin
C inter3: INPUT : total area in each bin
C         OUTPUT: total area in each bin

      CALL inter3(nw,wl,yg,n+1,x1,y1,0)
C      CALL inter2(nw,wl,yg,n,x3,y1,ierr)

      DO 10,iw = 1,nw-1
* from quanta s-1 cm-2 bin-1 to  watts m-2 nm-1
* 1.e4 * ([hc =] 6.62E-34 * 2.998E8)/(wc*1e-9)

C the scaling by bin width needs to be done only if
C inter3 is used for interpolation

         yg(iw) = yg(iw) / (wl(iw+1)-wl(iw))
         f(iw) = yg(iw) * 1.e4 * (6.62E-34 * 2.998E8) /( 0.5 * (wl(iw+
     $      1)+wl(iw)) * 1.e-9)

   10 CONTINUE

      RETURN
      END


*====================================================================
!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 610.1, GEOS/DAS      !
!-------------------------------------------------------------------------
! BOP
!
! !ROUTINE:  ods_sample -- Main Driver
!
! !DESCRIPTION: This routine reads a list of GEOS/DAS innovation files
!               in ODS format.
!
! !INTERFACE:
      program ods_sample
!
! !REVISION HISTORY:
!
!     12Dec2000  C. Redder  Original code.
!
! EOP
!-------------------------------------------------------------------------

      use m_ODS_Sample
      use m_ods,         only : ods_vect,
     .                          ODS_Get,
     .                          ODS_Put
      use m_die,         only : die
      use m_stdio,       only : stdout
      use m_StrTemplate, only : StrTemplate

      implicit NONE
      integer, external     :: ODS_CalDat
      integer, external     :: ODS_Julian

      type ( ods_vect )     :: Obs
      type ( ods_vect ), pointer, dimension (:) :: Binned_Obs

      integer               :: iret
      integer               :: NSyn1,  NSyn2,   iSyn,    NAllSyn
      integer               :: JHr1,   JHrBeg1, JHrEnd1, DJHr1
      integer               :: JHr2,   JHrBeg2, JHrEnd2, DJHr2
      integer               :: nymd1,  nhms1
      integer               :: nymd2,  nhms2
      real,   dimension (2) :: f
      integer               :: NFiles, iFile
      integer, parameter    :: NFiles_Max = 4096
      character (len = 255), dimension ( NFiles_Max )
     .                      :: InFiles
      character (len = 255) :: InFile, OutFile
      character (len = 255) :: TPlate
      character (len = 255) :: ExpID
      character (len = 255) :: Type
      character (len = *), parameter :: MyName = 'ODS_Sample::Main'
      integer, parameter    :: NLines_Max   = 4
      character (len = 100), dimension ( NLines_Max )
     .                      :: ErrorMessage

!     Initialize package
!     ------------------
      nullify ( Binned_Obs )
      call Init ( ExpID, NSyn2, f, TPlate, NFiles, InFiles )

!     For each input file ...
!     -----------------------
      do iFile = 1, NFiles

!        ... read relevant input file parameters
!        ---------------------------------------
         InFile = InFiles ( iFile )
         call Inquire_ODS ( InFile, NSyn1, JHrBeg1, JHrEnd1 )

!        ... and for each synoptic time in the input file ...
!        ----------------------------------------------------
         DJHr1  = 24 / NSyn1
         do JHr1 = JHrBeg1, JHrEnd1, DJHr1
            nymd1 = ODS_CalDat ( JHr1 / 24 + 1 )
            nhms1 =        mod ( JHr1,  24 ) * 10000

!           ... read the observation data
!           -----------------------------
            call ODS_Get ( InFile, nymd1, nhms1, Type, Obs, iret )
            if ( iret .ne. 0 ) then
               write ( ErrorMessage, 901 ) trim(InFile), iret
               call die ( MyName, ErrorMessage (:1) )

            end if

            if ( Obs%data%nobs<1 ) cycle

!           ... determine the synoptic times for the output file
!           ----------------------------------------------------
            call Set_SynTimes ( JHr1,  Obs % Data % Time, f,
     .                          NSyn2, JHrBeg2, JHrEnd2 )

!           Allocate space for the binned observations ...
!           ----------------------------------------------
            NAllSyn = ( JHrEnd2 - JHrBeg2 ) * NSyn2 / 24 + 1
            if ( associated ( Binned_Obs ) ) deallocate ( Binned_Obs )
            allocate ( Binned_Obs ( NAllSyn ), stat = iret )
            if ( iret .ne. 0 ) then
               write ( ErrorMessage, 902 ) 'Binned_Obs',
     .                                      trim ( ItoA ( NAllSyn )),
     .                                      trim ( ItoA ( iret    ))
               call die ( MyName, ErrorMessage ( :1 ) )

            end if

!           ... bin and sort the observation vectors
!               according to synoptic index time.
!           ----------------------------------------
            call Bin_Obs      ( JHr1, f, NSyn2, JHrBeg2, Type,
     .                          Obs,  Binned_Obs )

!           ... and for each synoptic time in the output file
!           -------------------------------------------------
            do iSyn = 1, NAllSyn
               JHr2  = JHrBeg2 + ( iSyn - 1 ) * 24 / NSyn2
               nymd2 = ODS_CalDat ( JHr2 / 24 + 1 )
               nhms2 =        mod ( JHr2,  24 ) * 10000

!              ... reset the time attribute to be consistent
!                  with the synoptic times for the output file
!              -----------------------------------------------
               call NewTime ( JHr1, JHr2,
     .                        Binned_Obs ( iSyn ) % Data % Time )

!              ... generate the name of the output file
!              ----------------------------------------
               call StrTemplate ( OutFile, TPlate,
     .                            xid  = ExpID,
     .                            nymd = nymd2,
     .                            nhms = nhms2 )

!              ... write the results to the output file
!              ----------------------------------------
               call ODS_Put     ( OutFile, Type,
     .                            nymd2,   nhms2,
     .                            Binned_Obs ( iSyn ),
     .                            iret,
     .                            append = .true. )
               if ( iret .ne. 0 ) then
                  write ( ErrorMessage, 903 ) trim (OutFile), iret
                  call die ( MyName, ErrorMessage (:1) )

               end if

            end do
         end do
         write ( stdout, 801 ) MyName, InFile

      end do

      call exit (0)
 801  format ( /, a, ': Processed input file, ', a )
 901  format ( ' Error in reading the ODS input file, ',  a,
     .          '; iret = ', i2 )
 902  format ( ' Error in allocating the array ', a, '(', a,
     .          '); iret = ', a )
 903  format ( ' Error in writing to the ODS output file, ', a,
     .          '; iret = ', i2 )

      end program ods_sample
*====================================================================


! SUMMA - Structure for Unifying Multiple Modeling Alternatives
! Copyright (C) 2014-2015 NCAR/RAL
!
! This file is part of SUMMA
!
! For more information see: http://www.ral.ucar.edu/projects/summa
!
! 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, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

module layerMerge_module
! data types
USE nrtype
! access named variables for snow and soil
USE globalData,only:iname_snow        ! named variables for snow
USE globalData,only:iname_soil        ! named variables for soil
! physical constants
USE multiconst,only:&
                    iden_ice,       & ! intrinsic density of ice             (kg m-3)
                    iden_water        ! intrinsic density of liquid water    (kg m-3)
! look-up values for the choice of method to combine and sub-divide snow layers
USE mDecisions_module,only:&
 sameRulesAllLayers, & ! SNTHERM option: same combination/sub-dividion rules applied to all layers
 rulesDependLayerIndex ! CLM option: combination/sub-dividion rules depend on layer index
! provide access to external modules
USE var_derive_module,only:calcHeight ! module to calculate height at layer interfaces and layer mid-point
implicit none
private
public::layerMerge
! provide access to the number layers throughout the module
integer(i4b)          :: nSnow                    ! number of snow layers
integer(i4b)          :: nSoil                    ! number of soil layers
integer(i4b)          :: nLayers                  ! total number of layers
! define missing values
real(dp)              :: missingDouble=-9999._dp  ! missing value (double precision)
integer(i4b)          :: missingInteger=-9999     ! missing value (integer)

contains

 ! *****************************************************************************************************************
 ! public subroutine layerMerge: merge layers if the thickness is less than zmin
 ! *****************************************************************************************************************
 subroutine layerMerge(&
                       ! input/output: model data structures
                       tooMuchMelt,                 & ! intent(in):    flag to force merge of snow layers
                       model_decisions,             & ! intent(in):    model decisions
                       mpar_data,                   & ! intent(in):    model parameters
                       indx_data,                   & ! intent(inout): type of each layer
                       prog_data,                   & ! intent(inout): model prognostic variables for a local HRU
                       diag_data,                   & ! intent(inout): model diagnostic variables for a local HRU
                       flux_data,                   & ! intent(inout): model fluxes for a local HRU
                       ! output
                       mergedLayers,                & ! intent(out): flag to denote that layers were merged
                       err,message)                   ! intent(out): error control
 ! --------------------------------------------------------------------------------------------------------
 ! --------------------------------------------------------------------------------------------------------
 ! access the derived types to define the data structures
 USE data_types,only:&
                     var_d,            & ! data vector (dp)
                     var_ilength,      & ! data vector with variable length dimension (i4b)
                     var_dlength,      & ! data vector with variable length dimension (dp)
                     model_options       ! defines the model decisions
 ! access metadata
 USE globalData,only:prog_meta,diag_meta,flux_meta,indx_meta   ! metadata
 ! access named variables defining elements in the data structures
 USE var_lookup,only:iLookPARAM,iLookPROG,iLookINDEX  ! named variables for structure elements
 USE var_lookup,only:iLookDECISIONS                   ! named variables for elements of the decision structure
 implicit none
 ! --------------------------------------------------------------------------------------------------------
 ! input/output: model data structures
 logical(lgt),intent(in)         :: tooMuchMelt         ! flag to denote that ice is insufficient to support melt
 type(model_options),intent(in)  :: model_decisions(:)  ! model decisions
 type(var_dlength),intent(in)    :: mpar_data           ! model parameters
 type(var_ilength),intent(inout) :: indx_data           ! type of each layer
 type(var_dlength),intent(inout) :: prog_data           ! model prognostic variables for a local HRU
 type(var_dlength),intent(inout) :: diag_data           ! model diagnostic variables for a local HRU
 type(var_dlength),intent(inout) :: flux_data           ! model flux variables
 ! output
 logical(lgt),intent(out)        :: mergedLayers        ! flag to denote that layers were merged
 integer(i4b),intent(out)        :: err                 ! error code
 character(*),intent(out)        :: message             ! error message
 ! --------------------------------------------------------------------------------------------------------
 ! define local variables
 character(LEN=256)              :: cmessage            ! error message of downwind routine
 real(dp),dimension(5)           :: zminLayer           ! minimum layer depth in each layer (m)
 logical(lgt)                    :: removeLayer         ! flag to indicate need to remove a layer
 integer(i4b)                    :: nCheck              ! number of layers to check for combination
 integer(i4b)                    :: iSnow               ! index of snow layers (looping)
 integer(i4b)                    :: jSnow               ! index of snow layer identified for combination with iSnow
 integer(i4b)                    :: kSnow               ! index of the upper layer of the two layers identified for combination
 ! initialize error control
 err=0; message="layerMerge/"
 ! --------------------------------------------------------------------------------------------------------
 ! associate variables to the data structures
 associate(&

 ! model decisions
 ix_snowLayers    => model_decisions(iLookDECISIONS%snowLayers)%iDecision, & ! decision for snow combination

 ! model parameters (control the depth of snow layers)
 zmin             => mpar_data%var(iLookPARAM%zmin)%dat(1),                & ! minimum layer depth (m)
 zminLayer1       => mpar_data%var(iLookPARAM%zminLayer1)%dat(1),          & ! minimum layer depth for the 1st (top) layer (m)
 zminLayer2       => mpar_data%var(iLookPARAM%zminLayer2)%dat(1),          & ! minimum layer depth for the 2nd layer (m)
 zminLayer3       => mpar_data%var(iLookPARAM%zminLayer3)%dat(1),          & ! minimum layer depth for the 3rd layer (m)
 zminLayer4       => mpar_data%var(iLookPARAM%zminLayer4)%dat(1),          & ! minimum layer depth for the 4th layer (m)
 zminLayer5       => mpar_data%var(iLookPARAM%zminLayer5)%dat(1),          & ! minimum layer depth for the 5th (bottom) layer (m)

 ! diagnostic scalar variables
 scalarSnowDepth  => prog_data%var(iLookPROG%scalarSnowDepth)%dat(1),      & ! total snow depth (m)
 scalarSWE        => prog_data%var(iLookPROG%scalarSWE)%dat(1)             & ! SWE (kg m-2)

 ) ! end associate statement
 ! --------------------------------------------------------------------------------------------------------

 ! identify algorithmic control parameters to syb-divide and combine snow layers
 zminLayer = (/zminLayer1, zminLayer2, zminLayer3, zminLayer4, zminLayer5/)

 ! intialize the modified layers flag
 mergedLayers=.false.

 ! initialize the number of snow layers
 nSnow = indx_data%var(iLookINDEX%nSnow)%dat(1)
 nSoil   = indx_data%var(iLookINDEX%nSoil)%dat(1)
 nLayers = indx_data%var(iLookINDEX%nLayers)%dat(1)

 kSnow=0 ! initialize first layer to test (top layer)
 do ! attempt to remove multiple layers in a single time step (continuous do loop with exit clause)

  ! special case of >5 layers: add an offset to use maximum threshold from layer above
  if(ix_snowLayers == rulesDependLayerIndex .and. nSnow > 5)then
   nCheck=5
  else
   nCheck=nSnow
  end if

  ! loop through snow layers
  do iSnow=kSnow+1,nCheck

   ! associate local variables with the information in the data structures
   ! NOTE: do this here, since the layer variables are re-defined
   associate(&
   mLayerDepth      => prog_data%var(iLookPROG%mLayerDepth)%dat         , &    ! depth of each layer (m)
   mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat    , &    ! volumetric fraction of ice in each layer  (-)
   mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat      &    ! volumetric fraction of liquid water in each layer (-)
   ) ! (associating local variables with the information in the data structures)

   ! check if the layer depth is less than the depth threshold
   select case(ix_snowLayers)
    case(sameRulesAllLayers);    removeLayer = (mLayerDepth(iSnow) < zmin)
    case(rulesDependLayerIndex); removeLayer = (mLayerDepth(iSnow) < zminLayer(iSnow))
    case default; err=20; message=trim(message)//'unable to identify option to combine/sub-divide snow layers'; return
   end select ! (option to combine/sub-divide snow layers)

   ! check if we have too much melt
   ! NOTE: assume that this is the top snow layer; need more trickery to relax this assumption
   if(tooMuchMelt .and. iSnow==1) removeLayer=.true.

   ! check if need to remove a layer
   if(removeLayer)then

    ! flag that we modified a layer
    mergedLayers=.true.

    ! ***** handle special case of a single layer
    if(nSnow==1)then
     ! set the variables defining "snow without a layer"
     ! NOTE: ignoring cold content!!! Need to fix later...
     scalarSnowDepth = mLayerDepth(1)
     scalarSWE       = (mLayerVolFracIce(1)*iden_ice + mLayerVolFracLiq(1)*iden_water)*mLayerDepth(1)
     ! remove the top layer from all model variable vectors
     ! NOTE: nSnow-1 = 0, so routine removes layer #1
     call rmLyAllVars(prog_data,prog_meta,nSnow-1,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
     call rmLyAllVars(diag_data,diag_meta,nSnow-1,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
     call rmLyAllVars(flux_data,flux_meta,nSnow-1,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
     call rmLyAllVars(indx_data,indx_meta,nSnow-1,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
     if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; end if
     ! update the total number of layers
     nSnow   = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow)
     nSoil   = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil)
     nLayers = nSnow + nSoil
     ! save the number of layers
     indx_data%var(iLookINDEX%nSnow)%dat(1)   = nSnow
     indx_data%var(iLookINDEX%nSoil)%dat(1)   = nSoil
     indx_data%var(iLookINDEX%nLayers)%dat(1) = nLayers
     ! update coordinate variables
     call calcHeight(&
                     ! input/output: data structures
                     indx_data,   & ! intent(in): layer type
                     prog_data,   & ! intent(inout): model variables for a local HRU
                     ! output: error control
                     err,cmessage)
     if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if
     ! exit the do loop (no more snow layers to remove)
     return
    end if  ! (special case of 1 layer --> snow without a layer)

    ! ***** identify the layer to combine
    if(iSnow==1)then
     jSnow = iSnow+1  ! upper-most layer, combine with its lower neighbor
    elseif(iSnow==nSnow)then
     jSnow = nSnow-1  ! lower-most layer, combine with its upper neighbor
    else
     if(mLayerDepth(iSnow-1)<mLayerDepth(iSnow+1))then; jSnow = iSnow-1; else; jSnow = iSnow+1; end if
    end if

    ! ***** combine layers
    ! identify the layer closest to the surface
    kSnow=min(iSnow,jSnow)
    ! combine layer with identified neighbor
    call layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,kSnow,err,cmessage)
    if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; end if

    ! exit the loop to try again
    exit

   end if  ! (if layer is below the mass threshold)

   kSnow=iSnow ! ksnow is used for completion test, so include here

   ! end association of local variables with the information in the data structures
   end associate

  end do ! (looping through snow layers)

  !print*, 'ksnow = ', ksnow

  ! exit if finished
  if(kSnow==nCheck)exit

 end do ! continuous do

 ! handle special case of > 5 layers in the CLM option
 if(nSnow > 5 .and. ix_snowLayers == rulesDependLayerIndex)then
  ! flag that layers were merged
  mergedLayers=.true.
  ! initial check to ensure everything is wonderful in the universe
  if(nSnow /= 6)then; err=5; message=trim(message)//'special case of > 5 layers: expect only six layers'; return; end if
  ! combine 5th layer with layer below
  call layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,5,err,cmessage)
  if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; end if
  ! another check
  if(nSnow /= 5)then; err=5; message=trim(message)//'special case of > 5 layers: expect to reduced layers to exactly 5'; return; end if
 end if

 ! check that there are no more than 5 layers in the CLM option
 if(ix_snowLayers == rulesDependLayerIndex)then
  if(nSnow > 5)then
   message=trim(message)//'expect no more than 5 layers when combination/sub-division rules depend on the layer index (CLM option)'
   err=20; return
  end if
 end if

 ! end association to variables in the data structure
 end associate

 end subroutine layerMerge

 ! ***********************************************************************************************************
 ! private subroutine layer_combine: combine snow layers and re-compute model state variables
 ! ***********************************************************************************************************
 ! combines layer iSnow with iSnow+1
 ! ***********************************************************************************************************
 subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow,err,message)
 ! provide access to variables in the data structures
 USE var_lookup,only:iLookPARAM,iLookPROG,iLookINDEX           ! named variables for structure elements
 USE globalData,only:prog_meta,diag_meta,flux_meta,indx_meta   ! metadata
 USE data_types,only:var_ilength,var_dlength                   ! data vectors with variable length dimension
 USE data_types,only:var_d                                     ! data structures with fixed dimension
 ! provide access to external modules
 USE snow_utils_module,only:fracliquid                         ! compute fraction of liquid water
 USE convE2Temp_module,only:E2T_nosoil,temp2ethpy              ! convert temperature to enthalpy
 implicit none
 ! ------------------------------------------------------------------------------------------------------------
 ! input/output: data structures
 type(var_dlength),intent(in)    :: mpar_data ! model parameters
 type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU
 type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU
 type(var_dlength),intent(inout) :: flux_data ! model flux variables
 type(var_ilength),intent(inout) :: indx_data ! type of model layer
 ! input: snow layer indices
 integer(i4b),intent(in)         :: iSnow     ! index of top layer to combine
 ! output: error control
 integer(i4b),intent(out)        :: err       ! error code
 character(*),intent(out)        :: message   ! error message
 ! ------------------------------------------------------------------------------------------------------------
 ! local variables
 character(len=256)              :: cmessage                 ! error message for downwind routine
 real(dp)                        :: massIce(2)               ! mass of ice in the two layers identified for combination (kg m-2)
 real(dp)                        :: massLiq(2)               ! mass of liquid water in the two layers identified for combination (kg m-2)
 real(dp)                        :: bulkDenWat(2)            ! bulk density if total water (liquid water plus ice) in the two layers identified for combination (kg m-3)
 real(dp)                        :: cBulkDenWat              ! combined bulk density of total water (liquid water plus ice) in the two layers identified for combination (kg m-3)
 real(dp)                        :: cTemp                    ! combined layer temperature
 real(dp)                        :: cDepth                   ! combined layer depth
 real(dp)                        :: cVolFracIce              ! combined layer volumetric fraction of ice
 real(dp)                        :: cVolFracLiq              ! combined layer volumetric fraction of liquid water
 real(dp)                        :: l1Enthalpy,l2Enthalpy    ! enthalpy in the two layers identified for combination (J m-3)
 real(dp)                        :: cEnthalpy                ! combined layer enthalpy (J m-3)
 real(dp)                        :: fLiq                     ! fraction of liquid water at the combined temperature cTemp
 real(dp),parameter              :: eTol=1.e-4_dp            ! tolerance for the enthalpy-->temperature conversion (J m-3)

 ! initialize error control
 err=0; message="layer_combine/"

 ! associate local variables with information in the data structures
 associate(&
 ! model parameters
 snowfrz_scale    => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1), & ! scaling parameter for the freezing curve for snow (K-1)
 ! model state variables
 mLayerTemp       => prog_data%var(iLookPROG%mLayerTemp)%dat       , & ! temperature of each layer (K)
 mLayerDepth      => prog_data%var(iLookPROG%mLayerDepth)%dat      , & ! depth of each layer (m)
 mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat , & ! volumetric fraction of ice in each layer  (-)
 mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat   & ! volumetric fraction of liquid water in each layer (-)
 ) ! (association of local variables with information in the data structures)

 ! compute combined depth
 cDepth       = mLayerDepth(isnow) + mLayerDepth(isnow+1)

 ! compute mass of each layer (kg m-2)
 massIce(1:2) = iden_ice*mLayerVolFracIce(iSnow:iSnow+1)*mLayerDepth(iSnow:iSnow+1)
 massLiq(1:2) = iden_water*mLayerVolFracLiq(iSnow:iSnow+1)*mLayerDepth(iSnow:iSnow+1)

 ! compute bulk density of water (kg m-3)
 bulkDenWat(1:2) = (massIce(1:2) + massLiq(1:2))/mLayerDepth(iSnow:iSnow+1)
 cBulkDenWat     = (mLayerDepth(isnow)*bulkDenWat(1) + mLayerDepth(isnow+1)*bulkDenWat(2))/cDepth

 ! compute enthalpy for each layer (J m-3)
 l1Enthalpy  = temp2ethpy(mLayerTemp(iSnow),  BulkDenWat(1),snowfrz_scale)
 l2Enthalpy  = temp2ethpy(mLayerTemp(iSnow+1),BulkDenWat(2),snowfrz_scale)

 ! compute combined enthalpy (J m-3)
 cEnthalpy   = (mLayerDepth(isnow)*l1Enthalpy + mLayerDepth(isnow+1)*l2Enthalpy)/cDepth

 ! convert enthalpy (J m-3) to temperature (K)
 call E2T_nosoil(cEnthalpy,cBulkDenWat,snowfrz_scale,cTemp,err,cmessage)
 if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; end if

 ! test enthalpy conversion
 if(abs(temp2ethpy(cTemp,cBulkDenWat,snowfrz_scale)/cBulkDenWat - cEnthalpy/cBulkDenWat) > eTol)then
  write(*,'(a,1x,f12.5,1x,2(e20.10,1x))') 'enthalpy test', cBulkDenWat, temp2ethpy(cTemp,cBulkDenWat,snowfrz_scale)/cBulkDenWat, cEnthalpy/cBulkDenWat
  message=trim(message)//'problem with enthalpy-->temperature conversion'
  err=20; return
 end if

 ! check temperature is within the two temperatures
 ! NOTE: use tolerance, for cases of merging a layer that has just been split
 if(cTemp > max(mLayerTemp(iSnow),mLayerTemp(iSnow+1))+eTol)then; err=20; message=trim(message)//'merged temperature > max(temp1,temp2)'; return; end if
 if(cTemp < min(mLayerTemp(iSnow),mLayerTemp(iSnow+1))-eTol)then; err=20; message=trim(message)//'merged temperature < min(temp1,temp2)'; return; end if

 ! compute volumetric fraction of liquid water
 fLiq = fracLiquid(cTemp,snowfrz_scale)

 ! compute volumetric fraction of ice and liquid water
 cVolFracLiq =          fLiq *cBulkDenWat/iden_water
 cVolFracIce = (1._dp - fLiq)*cBulkDenWat/iden_ice

 ! end association of local variables with information in the data structures
 end associate

 ! remove a model layer from all model variable vectors
 call rmLyAllVars(prog_data,prog_meta,iSnow,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
 call rmLyAllVars(diag_data,diag_meta,iSnow,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
 call rmLyAllVars(flux_data,flux_meta,iSnow,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
 call rmLyAllVars(indx_data,indx_meta,iSnow,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if

 ! define the combined layer as snow
 indx_data%var(iLookINDEX%layerType)%dat(iSnow) = iname_snow

 ! update the total number of layers
 nSnow   = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow)
 nSoil   = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil)
 nLayers = nSnow + nSoil

 ! save the number of layers in the data structures
 indx_data%var(iLookINDEX%nSnow)%dat(1)   = nSnow
 indx_data%var(iLookINDEX%nSoil)%dat(1)   = nSoil
 indx_data%var(iLookINDEX%nLayers)%dat(1) = nLayers

 ! ***** put state variables for the combined layer in the appropriate place
 prog_data%var(iLookPROG%mLayerTemp)%dat(iSnow)       = cTemp
 prog_data%var(iLookPROG%mLayerDepth)%dat(iSnow)      = cDepth
 prog_data%var(iLookPROG%mLayerVolFracIce)%dat(iSnow) = cVolFracIce
 prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(iSnow) = cVolFracLiq

 ! ***** adjust coordinate variables
 call calcHeight(&
                 ! input/output: data structures
                 indx_data,   & ! intent(in): layer type
                 prog_data,   & ! intent(inout): model variables for a local HRU
                 ! output: error control
                 err,cmessage)
 if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if

 end subroutine layer_combine

 ! ***********************************************************************************************************
 ! private subroutine rmLyAllVars: reduce the length of the vectors in data structures
 ! ***********************************************************************************************************
 ! removes layer "iSnow+1" and sets layer "iSnow" to a missing value
 ! (layer "iSnow" will be filled with a combined layer later)
 ! ***********************************************************************************************************
 subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,err,message)
 USE var_lookup,only:iLookVarType                 ! look up structure for variable typed
 USE get_ixName_module,only:get_varTypeName       ! to access type strings for error messages
 USE f2008funcs_module,only:cloneStruc            ! used to "clone" data structures -- temporary replacement of the intrinsic allocate(a, source=b)
 USE data_types,only:var_ilength,var_dlength      ! data vectors with variable length dimension
 USE data_types,only:var_info                     ! metadata structure
 implicit none
 ! ---------------------------------------------------------------------------------------------
 ! input/output: data structures
 class(*),intent(inout)          :: dataStruct     ! data structure
 type(var_info),intent(in)       :: metaStruct(:)  ! metadata structure
 ! input: snow layer indices
 integer(i4b),intent(in)         :: iSnow          ! new layer
 ! output: error control
 integer(i4b),intent(out)        :: err            ! error code
 character(*),intent(out)        :: message        ! error message
 ! locals
 integer(i4b)                    :: ivar           ! variable index
 integer(i4b)                    :: ix_lower       ! lower bound of the vector
 integer(i4b)                    :: ix_upper       ! upper bound of the vector
 real(dp),allocatable            :: tempVec_dp(:)  ! temporary vector (double precision)
 integer(i4b),allocatable        :: tempVec_i4b(:) ! temporary vector (integer)
 character(LEN=256)              :: cmessage       ! error message of downwind routine
 ! initialize error control
 err=0; message="rmLyAllVars/"

 ! check dimensions
 select type(dataStruct)
  type is (var_dlength); if(size(dataStruct%var) /= size(metaStruct)) err=20
  type is (var_ilength); if(size(dataStruct%var) /= size(metaStruct)) err=20
  class default; err=20; message=trim(message)//'unable to identify the data type'; return
 end select
 if(err/=0)then; message=trim(message)//'dimensions of data structure and metadata structures do not match'; return; end if

 ! ***** loop through model variables and remove one layer
 do ivar=1,size(metaStruct)

  ! define bounds
  select case(metaStruct(ivar)%vartype)
   case(iLookVarType%midSnow); ix_lower=1; ix_upper=nSnow
   case(iLookVarType%midToto); ix_lower=1; ix_upper=nLayers
   case(iLookVarType%ifcSnow); ix_lower=0; ix_upper=nSnow
   case(iLookVarType%ifcToto); ix_lower=0; ix_upper=nLayers
   case default; cycle  ! no need to remove soil layers or scalar variables
  end select

  ! remove layers
  select type(dataStruct)

   ! ** double precision
   type is (var_dlength)
    ! check allocated
    if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if
    ! allocate the temporary vector
    allocate(tempVec_dp(ix_lower:ix_upper-1), stat=err)
    if(err/=0)then; err=20; message=trim(message)//'unable to allocate temporary vector'; return; end if
    ! copy elements across to the temporary vector
    if(iSnow>=ix_lower)  tempVec_dp(iSnow)              = missingDouble ! set merged layer to missing (fill in later)
    if(iSnow>ix_lower)   tempVec_dp(ix_lower:iSnow-1)   = dataStruct%var(ivar)%dat(ix_lower:iSnow-1)
    if(iSnow+1<ix_upper) tempVec_dp(iSnow+1:ix_upper-1) = dataStruct%var(ivar)%dat(iSnow+2:ix_upper)  ! skip iSnow+1
    ! deallocate the data vector: strictly not necessary, but include to be safe
    deallocate(dataStruct%var(ivar)%dat,stat=err)
    if(err/=0)then; err=20; message='problem deallocating data vector'; return; end if
    ! create the new data structure using the temporary vector as the source
    call cloneStruc(dataStruct%var(ivar)%dat, ix_lower, source=tempVec_dp, err=err, message=cmessage)
    if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
    ! deallocate the temporary data vector: strictly not necessary, but include to be safe
    deallocate(tempVec_dp,stat=err)
    if(err/=0)then; err=20; message='problem deallocating temporary data vector'; return; end if

   ! ** integer
   type is (var_ilength)
    ! check allocated
    if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if
    ! allocate the temporary vector
    allocate(tempVec_i4b(ix_lower:ix_upper-1), stat=err)
    if(err/=0)then; err=20; message=trim(message)//'unable to allocate temporary vector'; return; end if
    ! copy elements across to the temporary vector
    if(iSnow>=ix_lower)  tempVec_i4b(iSnow)              = missingInteger ! set merged layer to missing (fill in later)
    if(iSnow>ix_lower)   tempVec_i4b(ix_lower:iSnow-1)   = dataStruct%var(ivar)%dat(ix_lower:iSnow-1)
    if(iSnow+1<ix_upper) tempVec_i4b(iSnow+1:ix_upper-1) = dataStruct%var(ivar)%dat(iSnow+2:ix_upper)  ! skip iSnow+1
    ! deallocate the data vector: strictly not necessary, but include to be safe
    deallocate(dataStruct%var(ivar)%dat,stat=err)
    if(err/=0)then; err=20; message='problem deallocating data vector'; return; end if
    ! create the new data structure using the temporary vector as the source
    call cloneStruc(dataStruct%var(ivar)%dat, ix_lower, source=tempVec_i4b, err=err, message=cmessage)
    if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
    ! deallocate the temporary data vector: strictly not necessary, but include to be safe
    deallocate(tempVec_i4b,stat=err)
    if(err/=0)then; err=20; message='problem deallocating temporary data vector'; return; end if

   ! check that we found the data type
   class default; err=20; message=trim(message)//'unable to identify the data type'; return

  end select ! dependence on data types

 end do  ! looping through variables

 end subroutine rmLyAllVars

end module layerMerge_module