c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c ... file vhags.f
c
c     this file contains code and documentation for subroutines
c     vhags and vhagsi
c
c ... files which must be loaded with vhags.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     subroutine vhags(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
c    +                 mdab,ndab,wvhags,lvhags,work,lwork,ierror)
c
c     subroutine vhags performs the vector spherical harmonic analysis
c     on the vector field (v,w) and stores the result in the arrays
c     br, bi, cr, and ci. v(i,j) and w(i,j) are the colatitudinal
c     (measured from the north pole) and east longitudinal components
c     respectively, located at the gaussian colatitude point theta(i)
c     and longitude phi(j) = (j-1)*2*pi/nlon. the spectral
c     representation of (v,w) is given at output parameters v,w in
c     subroutine vhses.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are computed
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     ityp   = 0  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon.
c
c            = 1  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 2  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 3  v is symmetric and w is antisymmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  v is symmetric and w is antisymmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 5  v is symmetric and w is antisymmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 6  v is antisymmetric and w is symmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  v is antisymmetric and w is symmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 8  v is antisymmetric and w is symmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c
c     nt     the number of analyses.  in the program that calls vhags,
c            the arrays v,w,br,bi,cr, and ci can be three dimensional
c            in which case multiple analyses will be performed.
c            the third index is the analysis index which assumes the
c            values k=1,...,nt.  for a single analysis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that all the arrays are two
c            dimensional.
c
c     v,w    two or three dimensional arrays (see input parameter nt)
c            that contain the vector function to be analyzed.
c            v is the colatitudnal component and w is the east
c            longitudinal component. v(i,j),w(i,j) contain the
c            components at the gaussian colatitude point theta(i)
c            and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges
c            are defined above at the input parameter ityp.
c
c     idvw   the first dimension of the arrays v,w as it appears in
c            the program that calls vhags. if ityp .le. 2 then idvw
c            must be at least nlat.  if ityp .gt. 2 and nlat is
c            even then idvw must be at least nlat/2. if ityp .gt. 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays v,w as it appears in
c            the program that calls vhags. jdvw must be at least nlon.
c
c     mdab   the first dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhags. mdab must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhags. ndab must be at
c            least nlat.
c
c     wvhags an array which must be initialized by subroutine vhgsi.
c            once initialized, wvhags can be used repeatedly by vhags
c            as long as nlon and nlat remain unchanged.  wvhags must
c            not be altered between calls of vhags.
c
c     lvhags the dimension of the array wvhags as it appears in the
c            program that calls vhags. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhags must be at least
c
c            l1*l2(nlat+nlat-l1+1)+nlon+15
c
c        ??? (nlat+1)*(nlat+1)*nlat/2 + nlon + 15
c
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vhags. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if ityp .le. 2 then lwork must be at least
c            the larger of the two quantities
c
c               3*nlat*(nlat+1)+2  (required by vhagsi)
c
c            and
c
c               (2*nt+1)*nlat*nlon
c
c            if ityp .gt. 2 then lwork must be at least
c            the larger of the two quantities
c
c               3*nlat*(nlat+1)+2  (required by vhagsi)
c
c            and
c
c              (2*nt+1)*l2*nlon
c
c
c     **************************************************************
c
c     output parameters
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c     cr,ci  that contain the vector spherical harmonic coefficients
c            in the spectral representation of v(i,j) and w(i,j) given
c            in the discription of subroutine vhses. br(mp1,np1),
c            bi(mp1,np1),cr(mp1,np1), and ci(mp1,np1) are computed
c            for mp1=1,...,mmax and np1=mp1,...,nlat except for np1=nlat
c            and odd mp1. mmax=min0(nlat,nlon/2) if nlon is even or
c            mmax=min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of ityp
c            = 4  error in the specification of nt
c            = 5  error in the specification of idvw
c            = 6  error in the specification of jdvw
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lvhags
c            = 10 error in the specification of lwork
c
c
c     subroutine vhagsi(nlat,nlon,wvhags,lvhags,work,lwork,ierror)
c
c     subroutine vhagsi initializes the array wvhags which can then be
c     used repeatedly by subroutine vhags until nlat or nlon is changed.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are computed
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     lvhags the dimension of the array wvhags as it appears in the
c            program that calls vhagsi.  define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhags must be at least
c
c               3*nlat*(nlat+1)+2  (required by vhagsi)
c
c     dwork  a double precision work space that does not need to be saved
c
c     ldwork the dimension of the array dwork as it appears in the
c            program that calls vhagsi. ldwork must be at least
c
c                   (3*nlat*(nlat+3)+2)/2
c
c     **************************************************************
c
c     output parameters
c
c     wvhags an array which is initialized for use by subroutine vhags.
c            once initialized, wvhags can be used repeatedly by vhags
c            as long as nlat and nlon remain unchanged.  wvhags must not
c            be altered between calls of vhags.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lvhags
c            = 4  error in the specification of ldwork
c
      subroutine vhags(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
     1           mdab,ndab,wvhags,lvhags,work,lwork,ierror)
      dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1),
     1          bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1),
     2          work(1),wvhags(1)
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 1) return
      ierror = 3
      if(ityp.lt.0 .or. ityp.gt.8) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((ityp.le.2 .and. idvw.lt.nlat) .or.
     1   (ityp.gt.2 .and. idvw.lt.imid)) return
      ierror = 6
      if(jdvw .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,(nlon+1)/2)
      if(mdab .lt. mmax) return
      ierror = 8
      if(ndab .lt. nlat) return
      ierror = 9
      idz = (mmax*(nlat+nlat-mmax+1))/2
      lzimn = idz*imid
      if(lvhags .lt. lzimn+lzimn+nlon+15) return
      ierror = 10
      idv = nlat
      if(ityp .gt. 2) idv = imid
      lnl = nt*idv*nlon
      if(lwork .lt. lnl+lnl+idv*nlon) return
      ierror = 0
      ist = 0
      if(ityp .le. 2) ist = imid
c
c     set wvhags pointers
c
      lmn = nlat*(nlat+1)/2
      jw1 = 1
      jw2 = jw1+imid*lmn
      jw3 = jw2+imid*lmn
c
c     set work pointers
c
      iw1 = ist+1
      iw2 = lnl+1
      iw3 = iw2+ist
      iw4 = iw2+lnl
      call vhags1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,ndab,
     +     br,bi,cr,ci,idv,work,work(iw1),work(iw2),work(iw3),
     +     work(iw4),idz,wvhags(jw1),wvhags(jw2),wvhags(jw3))
      return
      end

      subroutine vhags1(nlat,nlon,ityp,nt,imid,idvw,jdvw,v,w,mdab,
     +ndab,br,bi,cr,ci,idv,ve,vo,we,wo,work,idz,vb,wb,wrfft)
      dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1),
     1          bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1),
     2          ve(idv,nlon,1),vo(idv,nlon,1),we(idv,nlon,1),
     3          wo(idv,nlon,1),work(1),
     4          vb(imid,1),wb(imid,1),wrfft(1)
      nlp1 = nlat+1
      tsn = 2./nlon
      fsn = 4./nlon
      mlat = mod(nlat,2)
      mlon = mod(nlon,2)
      mmax = min0(nlat,(nlon+1)/2)
      imm1 = imid
      if(mlat .ne. 0) imm1 = imid-1
      if(ityp .gt. 2) go to 3
      do 5 k=1,nt
      do 5 i=1,imm1
      do 5 j=1,nlon
      ve(i,j,k) = tsn*(v(i,j,k)+v(nlp1-i,j,k))
      vo(i,j,k) = tsn*(v(i,j,k)-v(nlp1-i,j,k))
      we(i,j,k) = tsn*(w(i,j,k)+w(nlp1-i,j,k))
      wo(i,j,k) = tsn*(w(i,j,k)-w(nlp1-i,j,k))
    5 continue
      go to 2
    3 do 8 k=1,nt
      do 8 i=1,imm1
      do 8 j=1,nlon
      ve(i,j,k) = fsn*v(i,j,k)
      vo(i,j,k) = fsn*v(i,j,k)
      we(i,j,k) = fsn*w(i,j,k)
      wo(i,j,k) = fsn*w(i,j,k)
    8 continue
    2 if(mlat .eq. 0) go to 7
      do 6 k=1,nt
      do 6 j=1,nlon
      ve(imid,j,k) = tsn*v(imid,j,k)
      we(imid,j,k) = tsn*w(imid,j,k)
    6 continue
    7 do 9 k=1,nt
      call hrfftf(idv,nlon,ve(1,1,k),idv,wrfft,work)
      call hrfftf(idv,nlon,we(1,1,k),idv,wrfft,work)
    9 continue
      ndo1 = nlat
      ndo2 = nlat
      if(mlat .ne. 0) ndo1 = nlat-1
      if(mlat .eq. 0) ndo2 = nlat-1
      if(ityp.eq.2 .or. ityp.eq.5 .or. ityp.eq.8) go to 11
      do 10 k=1,nt
      do 10 mp1=1,mmax
      do 10 np1=mp1,nlat
      br(mp1,np1,k)=0.
      bi(mp1,np1,k)=0.
   10 continue
   11 if(ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) go to 13
      do 12 k=1,nt
      do 12 mp1=1,mmax
      do 12 np1=mp1,nlat
      cr(mp1,np1,k)=0.
      ci(mp1,np1,k)=0.
   12 continue
   13 itypp = ityp+1
      go to (1,100,200,300,400,500,600,700,800),itypp
c
c     case ityp=0 ,  no symmetries
c
c     case m=0
c
    1 do 15 k=1,nt
      do 15 i=1,imid
      do 15 np1=2,ndo2,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1)*ve(i,1,k)
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*we(i,1,k)
   15 continue
      do 16 k=1,nt
      do 16 i=1,imm1
      do 16 np1=3,ndo1,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1)*vo(i,1,k)
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*wo(i,1,k)
   16 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) return
      do 20 mp1=2,mmax
      m = mp1-1
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 17
      do 23 k=1,nt
      do 23 i=1,imm1
      do 23 np1=mp1,ndo1,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*we(i,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*we(i,2*mp1-2,k)
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*ve(i,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*ve(i,2*mp1-2,k)
   23 continue
      if(mlat .eq. 0) go to 17
      do 24 k=1,nt
      do 24 np1=mp1,ndo1,2
      br(mp1,np1,k) = br(mp1,np1,k)+wb(imid,np1+mb)*we(imid,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)-wb(imid,np1+mb)*we(imid,2*mp1-2,k)
      cr(mp1,np1,k) = cr(mp1,np1,k)+wb(imid,np1+mb)*ve(imid,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-wb(imid,np1+mb)*ve(imid,2*mp1-2,k)
   24 continue
   17 if(mp2 .gt. ndo2) go to 20
      do 21 k=1,nt
      do 21 i=1,imm1
      do 21 np1=mp2,ndo2,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*wo(i,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*wo(i,2*mp1-2,k)
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*vo(i,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*vo(i,2*mp1-2,k)
   21 continue
      if(mlat .eq. 0) go to 20
      do 22 k=1,nt
      do 22 np1=mp2,ndo2,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-2,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-1,k)
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-2,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-1,k)
   22 continue
   20 continue
      return
c
c     case ityp=1 ,  no symmetries but cr and ci equal zero
c
c     case m=0
c
  100 do 115 k=1,nt
      do 115 i=1,imid
      do 115 np1=2,ndo2,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1)*ve(i,1,k)
  115 continue
      do 116 k=1,nt
      do 116 i=1,imm1
      do 116 np1=3,ndo1,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1)*vo(i,1,k)
  116 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) return
      do 120 mp1=2,mmax
      m = mp1-1
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 117
      do 123 k=1,nt
      do 123 i=1,imm1
      do 123 np1=mp1,ndo1,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*we(i,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*we(i,2*mp1-2,k)
  123 continue
      if(mlat .eq. 0) go to 117
      do 124 k=1,nt
      do 124 np1=mp1,ndo1,2
      br(mp1,np1,k) = br(mp1,np1,k)+wb(imid,np1+mb)*we(imid,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)-wb(imid,np1+mb)*we(imid,2*mp1-2,k)
  124 continue
  117 if(mp2 .gt. ndo2) go to 120
      do 121 k=1,nt
      do 121 i=1,imm1
      do 121 np1=mp2,ndo2,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*wo(i,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*wo(i,2*mp1-2,k)
  121 continue
      if(mlat .eq. 0) go to 120
      do 122 k=1,nt
      do 122 np1=mp2,ndo2,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-2,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-1,k)
  122 continue
  120 continue
      return
c
c     case ityp=2 ,  no symmetries but br and bi equal zero
c
c     case m=0
c
  200 do 215 k=1,nt
      do 215 i=1,imid
      do 215 np1=2,ndo2,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*we(i,1,k)
  215 continue
      do 216 k=1,nt
      do 216 i=1,imm1
      do 216 np1=3,ndo1,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*wo(i,1,k)
  216 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) return
      do 220 mp1=2,mmax
      m = mp1-1
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 217
      do 223 k=1,nt
      do 223 i=1,imm1
      do 223 np1=mp1,ndo1,2
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*ve(i,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*ve(i,2*mp1-2,k)
  223 continue
      if(mlat .eq. 0) go to 217
      do 224 k=1,nt
      do 224 np1=mp1,ndo1,2
      cr(mp1,np1,k) = cr(mp1,np1,k)+wb(imid,np1+mb)*ve(imid,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-wb(imid,np1+mb)*ve(imid,2*mp1-2,k)
  224 continue
  217 if(mp2 .gt. ndo2) go to 220
      do 221 k=1,nt
      do 221 i=1,imm1
      do 221 np1=mp2,ndo2,2
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*vo(i,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*vo(i,2*mp1-2,k)
  221 continue
      if(mlat .eq. 0) go to 220
      do 222 k=1,nt
      do 222 np1=mp2,ndo2,2
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-2,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-1,k)
  222 continue
  220 continue
      return
c
c     case ityp=3 ,  v even , w odd
c
c     case m=0
c
  300 do 315 k=1,nt
      do 315 i=1,imid
      do 315 np1=2,ndo2,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1)*ve(i,1,k)
  315 continue
      do 316 k=1,nt
      do 316 i=1,imm1
      do 316 np1=3,ndo1,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*wo(i,1,k)
  316 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) return
      do 320 mp1=2,mmax
      m = mp1-1
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 317
      do 323 k=1,nt
      do 323 i=1,imm1
      do 323 np1=mp1,ndo1,2
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*ve(i,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*ve(i,2*mp1-2,k)
  323 continue
      if(mlat .eq. 0) go to 317
      do 324 k=1,nt
      do 324 np1=mp1,ndo1,2
      cr(mp1,np1,k) = cr(mp1,np1,k)+wb(imid,np1+mb)*ve(imid,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-wb(imid,np1+mb)*ve(imid,2*mp1-2,k)
  324 continue
  317 if(mp2 .gt. ndo2) go to 320
      do 321 k=1,nt
      do 321 i=1,imm1
      do 321 np1=mp2,ndo2,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*wo(i,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*wo(i,2*mp1-2,k)
  321 continue
      if(mlat .eq. 0) go to 320
      do 322 k=1,nt
      do 322 np1=mp2,ndo2,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-2,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-1,k)
  322 continue
  320 continue
      return
c
c     case ityp=4 ,  v even, w odd, and cr and ci equal 0.
c
c     case m=0
c
  400 do 415 k=1,nt
      do 415 i=1,imid
      do 415 np1=2,ndo2,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1)*ve(i,1,k)
  415 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) return
      do 420 mp1=2,mmax
      m = mp1-1
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp2 .gt. ndo2) go to 420
      do 421 k=1,nt
      do 421 i=1,imm1
      do 421 np1=mp2,ndo2,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*wo(i,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*ve(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*wo(i,2*mp1-2,k)
  421 continue
      if(mlat .eq. 0) go to 420
      do 422 k=1,nt
      do 422 np1=mp2,ndo2,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-2,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(imid,np1+mb)*ve(imid,2*mp1-1,k)
  422 continue
  420 continue
      return
c
c     case ityp=5   v even, w odd, and br and bi equal zero
c
c     case m=0
c
  500 do 516 k=1,nt
      do 516 i=1,imm1
      do 516 np1=3,ndo1,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*wo(i,1,k)
  516 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) return
      do 520 mp1=2,mmax
      m = mp1-1
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 520
      do 523 k=1,nt
      do 523 i=1,imm1
      do 523 np1=mp1,ndo1,2
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*ve(i,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*wo(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*ve(i,2*mp1-2,k)
  523 continue
      if(mlat .eq. 0) go to 520
      do 524 k=1,nt
      do 524 np1=mp1,ndo1,2
      cr(mp1,np1,k) = cr(mp1,np1,k)+wb(imid,np1+mb)*ve(imid,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-wb(imid,np1+mb)*ve(imid,2*mp1-2,k)
  524 continue
  520 continue
      return
c
c     case ityp=6 ,  v odd , w even
c
c     case m=0
c
  600 do 615 k=1,nt
      do 615 i=1,imid
      do 615 np1=2,ndo2,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*we(i,1,k)
  615 continue
      do 616 k=1,nt
      do 616 i=1,imm1
      do 616 np1=3,ndo1,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1)*vo(i,1,k)
  616 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) return
      do 620 mp1=2,mmax
      m = mp1-1
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 617
      do 623 k=1,nt
      do 623 i=1,imm1
      do 623 np1=mp1,ndo1,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*we(i,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*we(i,2*mp1-2,k)
  623 continue
      if(mlat .eq. 0) go to 617
      do 624 k=1,nt
      do 624 np1=mp1,ndo1,2
      br(mp1,np1,k) = br(mp1,np1,k)+wb(imid,np1+mb)*we(imid,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)-wb(imid,np1+mb)*we(imid,2*mp1-2,k)
  624 continue
  617 if(mp2 .gt. ndo2) go to 620
      do 621 k=1,nt
      do 621 i=1,imm1
      do 621 np1=mp2,ndo2,2
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*vo(i,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*vo(i,2*mp1-2,k)
  621 continue
      if(mlat .eq. 0) go to 620
      do 622 k=1,nt
      do 622 np1=mp2,ndo2,2
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-2,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-1,k)
  622 continue
  620 continue
      return
c
c     case ityp=7   v odd, w even, and cr and ci equal zero
c
c     case m=0
c
  700 do 716 k=1,nt
      do 716 i=1,imm1
      do 716 np1=3,ndo1,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1)*vo(i,1,k)
  716 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) return
      do 720 mp1=2,mmax
      m = mp1-1
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp1 .gt. ndo1) go to 720
      do 723 k=1,nt
      do 723 i=1,imm1
      do 723 np1=mp1,ndo1,2
      br(mp1,np1,k) = br(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*we(i,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1+mb)*vo(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*we(i,2*mp1-2,k)
  723 continue
      if(mlat .eq. 0) go to 720
      do 724 k=1,nt
      do 724 np1=mp1,ndo1,2
      br(mp1,np1,k) = br(mp1,np1,k)+wb(imid,np1+mb)*we(imid,2*mp1-1,k)
      bi(mp1,np1,k) = bi(mp1,np1,k)-wb(imid,np1+mb)*we(imid,2*mp1-2,k)
  724 continue
  720 continue
      return
c
c     case ityp=8   v odd, w even, and both br and bi equal zero
c
c     case m=0
c
  800 do 815 k=1,nt
      do 815 i=1,imid
      do 815 np1=2,ndo2,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1)*we(i,1,k)
  815 continue
c
c     case m = 1 through nlat-1
c
      if(mmax .lt. 2) return
      do 820 mp1=2,mmax
      m = mp1-1
      mb = m*nlat-(m*(m+1))/2
      mp2 = mp1+1
      if(mp2 .gt. ndo2) go to 820
      do 821 k=1,nt
      do 821 i=1,imm1
      do 821 np1=mp2,ndo2,2
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-2,k)
     1                             +wb(i,np1+mb)*vo(i,2*mp1-1,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1+mb)*we(i,2*mp1-1,k)
     1                             -wb(i,np1+mb)*vo(i,2*mp1-2,k)
  821 continue
      if(mlat .eq. 0) go to 820
      do 822 k=1,nt
      do 822 np1=mp2,ndo2,2
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-2,k)
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(imid,np1+mb)*we(imid,2*mp1-1,k)
  822 continue
  820 continue
      return
      end
      subroutine vhagsi(nlat,nlon,wvhags,lvhags,dwork,ldwork,ierror)
      dimension wvhags(lvhags)
      double precision dwork(ldwork)
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 1) return
      ierror = 3
      imid = (nlat+1)/2
      lmn = (nlat*(nlat+1))/2
      if(lvhags .lt. 2*(imid*lmn)+nlon+15) return
      ierror = 4
c     if (ldwork.lt.nlat*(3*nlat+9)+2) return
      if (ldwork.lt.(nlat*(3*nlat+9)+2)/2) return
      ierror = 0
      jw1 = 1
      jw2 = jw1+imid*lmn
      jw3 = jw2+imid*lmn
      iw1 = 1
      iw2 = iw1+nlat
      iw3 = iw2+nlat
      iw4 = iw3+3*imid*nlat
c     iw2 = iw1+nlat+nlat
c     iw3 = iw2+nlat+nlat
c     iw4 = iw3+6*imid*nlat
      call vhgai1(nlat,imid,wvhags(jw1),wvhags(jw2),
     +dwork(iw1),dwork(iw2),dwork(iw3),dwork(iw4))
      call hrffti(nlon,wvhags(jw3))
      return
      end
      subroutine vhgai1(nlat,imid,vb,wb,dthet,dwts,dpbar,work)
      dimension vb(imid,*),wb(imid,*)
      double precision abel,bbel,cbel,ssqr2,dcf
      double precision dpbar(imid,nlat,3), dthet(*),dwts(*),work(*)
c     lwk = 4*nlat*(nlat+2)
      lwk = nlat*(nlat+2)
      call gaqd(nlat,dthet,dwts,dpbar,lwk,ierror)
c
c     compute associated legendre functions
c
c     compute m=n=0 legendre polynomials for all theta(i)
c
      ssqr2 = 1./dsqrt(2.d0)
      do 90 i=1,imid
      dpbar(i,1,1) = ssqr2
      vb(i,1) = 0.
      wb(i,1) = 0.
   90 continue
c
c     main loop for remaining vb, and wb
c
      do 100 n=1,nlat-1
      nm = mod(n-2,3)+1
      nz = mod(n-1,3)+1
      np = mod(n,3)+1
c
c     compute dpbar for m=0
c
      call dnlfk(0,n,work)
      mn = indx(0,n,nlat)
      do 105 i=1,imid
      call dnlft(0,n,dthet(i),work,dpbar(i,1,np))
  105 continue
c
c     compute dpbar for m=1
c
      call dnlfk(1,n,work)
      mn = indx(1,n,nlat)
      do 106 i=1,imid
      call dnlft(1,n,dthet(i),work,dpbar(i,2,np))
c      pbar(i,mn) = dpbar(i,2,np)
  106 continue
  104 continue
c
c     compute and store dpbar for m=2,n
c
      if(n.lt.2) go to 108
      do 107 m=2,n
      abel = dsqrt(dble(float((2*n+1)*(m+n-2)*(m+n-3)))/
     1                dble(float((2*n-3)*(m+n-1)*(m+n))))
      bbel = dsqrt(dble(float((2*n+1)*(n-m-1)*(n-m)))/
     1                dble(float((2*n-3)*(m+n-1)*(m+n))))
      cbel = dsqrt(dble(float((n-m+1)*(n-m+2)))/
     1                dble(float((m+n-1)*(m+n))))
      id = indx(m,n,nlat)
      if (m.ge.n-1) go to 102
      do 103 i=1,imid
      dpbar(i,m+1,np) = abel*dpbar(i,m-1,nm)+bbel*dpbar(i,m+1,nm)
     1                                         -cbel*dpbar(i,m-1,np)
  103 continue
      go to 107
  102 do 101 i=1,imid
      dpbar(i,m+1,np) = abel*dpbar(i,m-1,nm)-cbel*dpbar(i,m-1,np)
  101 continue
  107 continue
c
c     compute the derivative of the functions
c
  108 continue
      ix = indx(0,n,nlat)
      iy = indx(n,n,nlat)
      do 125 i=1,imid
      vb(i,ix) = -dpbar(i,2,np)*dwts(i)
      vb(i,iy) = dpbar(i,n,np)/dsqrt(dble(float(2*(n+1))))*dwts(i)
125   continue
c
      if(n.eq.1) go to 131
      dcf = dsqrt(dble(float(4*n*(n+1))))
      do 130 m=1,n-1
      ix = indx(m,n,nlat)
      abel = dsqrt(dble(float((n+m)*(n-m+1))))/dcf
      bbel = dsqrt(dble(float((n-m)*(n+m+1))))/dcf
      do 130 i=1,imid
      vb(i,ix) = (abel*dpbar(i,m,np)-bbel*dpbar(i,m+2,np))*dwts(i)
130   continue
c
c     compute the vector harmonic w(theta) = m*pbar/cos(theta)
c
c     set wb=0 for m=0
c
  131 continue
      ix = indx(0,n,nlat)
      do 220 i=1,imid
      wb(i,ix) = 0.d0
220   continue
c
c     compute wb for m=1,n
c
      dcf = dsqrt(dble(float(n+n+1))/dble(float(4*n*(n+1)*(n+n-1))))
      do 230 m=1,n
      ix = indx(m,n,nlat)
      abel = dcf*dsqrt(dble(float((n+m)*(n+m-1))))
      bbel = dcf*dsqrt(dble(float((n-m)*(n-m-1))))
      if(m.ge.n-1) go to 231
      do 229 i=1,imid
      wb(i,ix) = (abel*dpbar(i,m,nz) + bbel*dpbar(i,m+2,nz))*dwts(i)
  229 continue
      go to 230
  231 do 228 i=1,imid
      wb(i,ix) = abel*dpbar(i,m,nz)*dwts(i)
  228 continue
  230 continue
  100 continue
      return
      end

      function indx(m,n,nlat)
      integer indx
      indx = m*nlat-(m*(m+1))/2+n+1
      return
      end


! File: example1.f90
!
! This file is part of the SpanLib library.
! Copyright (C) 2006  Stephane Raynaud
! Contact: stephane dot raynaud at gmail dot com
!
! This library is free software; you can redistribute it and/or
! modify it under the terms of the GNU Lesser General Public
! License as published by the Free Software Foundation; either
! version 2.1 of the License, or (at your option) any later version.
!
! This library 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
! Lesser General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public
! License along with this library; if not, write to the Free Software
! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

program example

	! This simple example shows how to PCA and MSSA subroutines from this package.
	! Warning: it requires netcdf for in/outputs.
	!
	! We start from longitude/latitude/time value of Pacific Sea Surface Temperature
	! that include the El Nino Southern Oscillation signal.
	! Input is the netcdf file data2.cdf.
	! We remove land points from the initial array according
	! to the netcdf missing_value attribute of the analysed variable (data are "packed").
	! A PCA is used to reduce the degrees of freedoom before MSSA analysis.
	! Weights for PCA are computed as a fonction of latitude.
	! Then, we assume that we have already identified an oscillation (after tests).
	! This oscillation, given by a pair of MSSA modes, is then
	! reconstructed from the MSSA and PCA spaces.
	! Finally, phase composites are computed from this reconstructed oscillation.
	! The oscillation is outputed in a netcdf file (pair_1.cdf).
	! MSSA eigenvalue are stored in the output netcdf file. This shows
	! you pairs due to oscillatory modes.
	!
	! Initial data set (data2.cdf):
	! - origin: updated Reynolds and Smith (1996) SST (netcdf file)
	! - origin url: data selector from http://iridl.ldeo.columbia.edu
	! - how to get it [10Mb]: http://stefdeperou.free.fr/pub/data.cdf
	! - area of study: tropical pacific [130.5E:75.5W, 29.5S:29.5N] (155x60 grid points)
	! - period of study: Jan1982:Dec2005 (288 time steps)
	!
	! Parameters:
	! - Only the first 20 PCs are retainedand given to the MSSA
	! - A window of 7 years (84 months) is chosen for the MSSA
	! - Phase composites use 8 phases
	! - An offset of 0.4 and is used for composites
	! - The first phase of composites is set at 180 degrees (minimal value)
	!
	! Note:
	!	This example should run only a few seconds.
	!	If it is not the case, your BLAS/LAPACK librairy is not optimized.

	use spanlib
	use netcdf

	implicit none

	! Parameters
	! ----------
	integer,parameter :: nkeep_pca=10, nkeep_mssa=6, nwindow=84, &
		& first_mode=1, nphases=8
	real(wp), parameter :: offset=0.d0, first_phase=180.d0, &
		& new_missing_value=-999.d0
	character(len=20), parameter :: input_nc_file="data2.cdf", &
		& output_nc_file="output_fortran1.nc", var_name='ssta'

	! Other declarations
	! ------------------
	real(wp), allocatable :: field(:,:,:), weights(:,:), &
		& lat(:), lon(:), time(:)
	real(wp), allocatable :: reco(:,:,:), phasecomps(:,:,:)
	logical, allocatable :: mask(:,:)
	real(wp), allocatable :: packed_field(:,:), &
		& packed_weights(:), packed_phasecomps(:,:), stphasecomps(:,:)
	real(wp), allocatable :: eof(:,:), pc(:,:), &
		& stpair(:,:), pair(:,:)
	real(wp), allocatable :: steof(:,:),stpc(:,:),stev(:)
	character(len=20) :: lon_units, lat_units, var_units, &
		&	lon_name, lat_name, time_name, time_units
	integer :: ncid, dimids(5), varid, lonid, latid, phaseid, &
		& timeid, phcoid, recoid, origid, modeid, evid
	integer(kind=4) :: i, nspace, nlon, nlat, ntime
	real(wp) :: pi, missing_value

	! Precision
	! ---------
	if(wp==8)then
		print*,'Using double precision'
	else
		print*,'Using simple precision'
	end if

	! Get the initial sst field from the netcdf file
	! ----------------------------------------------
	print*,'Reading inputs...'
	call err(nf90_open(input_nc_file, nf90_nowrite, ncid))
	call err(nf90_inq_varid(ncid, var_name, varid))
	call err(nf90_inquire_variable(ncid, varid, dimids=dimids(1:3)))
	call err(nf90_inquire_dimension(ncid, dimids(1), &
		&	name=lon_name, len=nlon))
	call err(nf90_inquire_dimension(ncid, dimids(2), &
		&	name=lat_name, len=nlat))
	call err(nf90_inquire_dimension(ncid, dimids(3), &
		&	name=time_name, len=ntime))
	allocate(field(nlon,nlat,ntime))
	allocate(mask(nlon,nlat))
	allocate(weights(nlon,nlat))
	allocate(lon(nlon))
	allocate(lat(nlat))
	allocate(time(ntime))
	call err(nf90_get_var(ncid, varid, field))
	call err(nf90_get_att(ncid, varid, 'missing_value', &
		& missing_value))
	call err(nf90_get_att(ncid, varid, 'units', var_units))
	call err(nf90_inq_varid(ncid, lon_name, varid))
	call err(nf90_get_var(ncid, varid, lon))
	call err(nf90_get_att(ncid, varid, 'units', lon_units))
	call err(nf90_inq_varid(ncid, lat_name, varid))
	call err(nf90_get_var(ncid, varid, lat))
	call err(nf90_get_att(ncid, varid, 'units', lat_units))
	call err(nf90_inq_varid(ncid, time_name, varid))
	call err(nf90_get_var(ncid, varid, time))
	call err(nf90_get_att(ncid, varid, 'units', time_units))
	call err(nf90_close(ncid))

	! Format (pack) data to have only one space dimension
	! ---------------------------------------------------
	print*,'Packing...'

	! Compute weights proportional to grid point area
	pi = cos(-1.)
	do i=1,nlat
		weights(:,i) = cos(lat(i)*pi/180.)
	end do

	! Now pack
	mask = (field(:,:,1) /= missing_value)
	allocate(packed_field(count(mask), ntime))
	do i=1, ntime
		packed_field(:,i) = pack(field(:,:,i), mask)
	end do
	nspace = count(mask)
	allocate(packed_weights(nspace))
	packed_weights = pack(weights, mask)

	! Perform a PCA to reduce the d.o.f
	! ---------------------------------
	print*,'[sl_pca] Pre-PCA...'
	allocate(eof(nspace, nkeep_pca))
	allocate(pc(ntime,   nkeep_pca))
	call sl_pca(packed_field, nkeep_pca, xeof=eof, &
		&	pc=pc, weights=packed_weights)
	deallocate(packed_field)

	! We send results from PCA to MSSA
	! --------------------------------
	print*,'[sl_mssa] MSSA...'
	allocate(steof(nkeep_pca*nwindow, nkeep_mssa))
	allocate(stpc(ntime-nwindow+1,    nkeep_mssa))
	allocate(stev(                    nkeep_mssa))
	call sl_mssa(transpose(pc), nwindow, nkeep_mssa, &
		&	steof=steof, stpc=stpc, ev=stev)

	! We reconstruct modes [first_mode + first_mode+1] of MSSA
	! --------------------------------------------------------
	print*,'[sl_mssa_rec] MSSA reconstruction...'
	allocate(stpair(nkeep_pca, ntime))
	call sl_mssa_rec(steof(:,first_mode:first_mode+1), &
		& stpc(:,first_mode:first_mode+1), nwindow, stpair)
	deallocate(steof, stpc)

	! We compute phases composites for the reconstructed oscillation
	! ---------------------------------------------------------------
	print*,'[sl_phasecomp] Phase composites...'
	allocate(stphasecomps(nkeep_pca, nphases))
	call sl_phasecomp(stpair, nphases, stphasecomps, &
		&	offset=offset, firstphase=first_phase)

	! We go back to the physical space for
	! the full oscillation AND its composites
	! ---------------------------------------
	print*,'[sl_pca_rec] Back to the physical space...'
	allocate(pair(nspace, ntime))
	call sl_pca_rec(eof, transpose(stpair), pair)
	allocate(packed_phasecomps(nspace, nphases))
	call sl_pca_rec(eof, transpose(stphasecomps), packed_phasecomps)
	deallocate(stpair, eof, stphasecomps)

	! Unpacking
	! ---------
	print*,'Unpacking...'
	allocate(reco(nlon,nlat,ntime))
	do i=1, ntime
		reco(:,:,i) = unpack(pair(:,i), mask, new_missing_value)
		where(.not.mask)field(:,:,i) = new_missing_value
	end do
	allocate(phasecomps(nlon,nlat,nphases))
	do i=1, nphases
		phasecomps(:,:,i) = unpack(packed_phasecomps(:,i), mask, &
		 & new_missing_value)
	end do

	! Write out the phase composites of the first oscillation
	! -------------------------------------------------------
	print*,'Writing out...'
	! File
	call err(nf90_create(output_nc_file, nf90_write, ncid))
	! Dimensions
	call err(nf90_def_dim(ncid, 'lon', nlon, dimids(1)))
	call err(nf90_def_dim(ncid, 'lat', nlat, dimids(2)))
	call err(nf90_def_dim(ncid, 'time', ntime, dimids(3)))
	call err(nf90_def_dim(ncid, 'phase', nphases, dimids(4)))
	call err(nf90_def_dim(ncid, 'mode', nkeep_mssa, dimids(5)))
	! Variables
	call err(nf90_def_var(ncid, 'lon', nf90_float, dimids(1), lonid))
	call err(nf90_put_att(ncid, lonid, 'long_name', 'Longitude'))
	call err(nf90_put_att(ncid, lonid, 'units', lon_units))
	call err(nf90_def_var(ncid, 'lat', nf90_float, dimids(2), latid))
	call err(nf90_put_att(ncid, latid, 'long_name', 'Latitude'))
	call err(nf90_put_att(ncid, latid, 'units', lat_units))
	call err(nf90_def_var(ncid, 'time', nf90_float, dimids(3), &
		& timeid))
	call err(nf90_put_att(ncid, timeid, 'long_name', 'Time'))
	call err(nf90_put_att(ncid, timeid, 'units', time_units))
	call err(nf90_def_var(ncid, 'phase', nf90_float, dimids(4), &
		& phaseid))
	call err(nf90_put_att(ncid, phaseid, 'long_name', 'Phase'))
	call err(nf90_put_att(ncid, phaseid, 'units', 'level'))
	call err(nf90_def_var(ncid, 'mode', nf90_float, dimids(5), &
		& modeid))
	call err(nf90_put_att(ncid, modeid, 'long_name', 'Mode'))
	call err(nf90_put_att(ncid, modeid, 'units', 'level'))
	call err(nf90_def_var(ncid, 'orig', nf90_float, dimids(1:3), &
	 & origid))
	call err(nf90_put_att(ncid, origid, 'long_name', &
		& 'SST anomaly / original field'))
	call err(nf90_put_att(ncid, origid, 'units', var_units))
	call err(nf90_put_att(ncid, origid, 'missing_value', &
		& new_missing_value))
	call err(nf90_def_var(ncid, 'reco1', nf90_float, dimids(1:3), &
		& recoid))
	call err(nf90_put_att(ncid, recoid, 'long_name', &
		& 'SST anomaly / reconstruction of first pair'))
	call err(nf90_put_att(ncid, recoid, 'units', var_units))
	call err(nf90_put_att(ncid, recoid, 'missing_value', &
		& new_missing_value))
	call err(nf90_def_var(ncid, 'pair1', nf90_float, &
		& (/dimids(1),dimids(2),dimids(4)/), phcoid))
	call err(nf90_put_att(ncid, phcoid, 'long_name', &
		&'SST anomaly / phase composite of first pair'))
	call err(nf90_put_att(ncid, phcoid, 'units', var_units))
	call err(nf90_put_att(ncid, phcoid, 'missing_value', &
		& new_missing_value))
	call err(nf90_def_var(ncid, 'ev', nf90_float, dimids(5), evid))
	call err(nf90_put_att(ncid, evid, 'long_name', &
		&'MSSA eigen values'))
	! Values
	call err(nf90_enddef(ncid))
	call err(nf90_put_var(ncid, lonid, lon))
	call err(nf90_put_var(ncid, latid, lat))
	call err(nf90_put_var(ncid, timeid, time))
	call err(nf90_put_var(ncid, phaseid, float((/(i,i=1,nphases)/))))
	call err(nf90_put_var(ncid, modeid, &
		& float((/(i,i=1,nkeep_mssa)/))))
	call err(nf90_put_var(ncid, origid, field))
	call err(nf90_put_var(ncid, recoid, reco))
	call err(nf90_put_var(ncid, phcoid, phasecomps))
	call err(nf90_put_var(ncid, evid, stev))
	call err(nf90_close(ncid))

end program example

subroutine err(jstatus)

	use netcdf

	integer :: jstatus

	if (jstatus .ne. nf90_noerr) then
		print *, trim(nf90_strerror(jstatus))
		stop
	end if

end subroutine err


PROGRAM main_weight
    use mo_weight
    use mo_profile

    ! use procedures
    ! use netcdf,          only: &
    !    nf90_open, nf90_close, nf90_strerror, nf90_def_dim, nf90_def_var,   &
    !    nf90_put_var, nf90_get_var, nf90_put_att, nf90_get_att,             &
    !    nf90_inquire, nf90_inq_dimid, nf90_inquire_dimension,               &
    !    nf90_inq_varid, nf90_inq_varids, nf90_inquire_variable, nf90_inquire_attribute,      &
    !    NF90_OPEN, NF90_NETCDF4, NF90_CREATE, NF90_WRITE, NF90_NOWRITE,     &
    !    NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE,                      &
    !    NF90_FILL_BYTE, NF90_FILL_SHORT, NF90_FILL_INT, NF90_FILL_FLOAT , NF90_FILL_DOUBLE, &
    !    NF90_NOERR, NF90_UNLIMITED, NF90_GLOBAL

    real mat(2, 3), ws(2, 3), vec(6), w(6)

    LOGICAL mask(2, 3)
    integer fid

    vec = (/7.0, 2.0, 0.0, -5.0, 0.0, 4.0/)
    w   = (/0.5, 1.0, 1.0, 1.0, 1.0, 1.0/)

    mat = RESHAPE(vec, (/2, 3/))
    ws  = RESHAPE(w  , (/2, 3/))

    mask = mat /= 0
    ! print *, mat
    ! call tic
    print *, mask

    fid = init()
    call tic("[1.1 mat wsum] ---------------")

    ! write(fid, *) ws
    write(fid, *) wsum_mat(mat)
    write(fid, *) wsum_mat(mat, ws)
    write(fid, *) wsum(mat, ws, mask)
    write(fid, *) wsum_mat(mat, ws, mat /= 0)
    write(fid, *) wsum_mat(mat, ws, mat /= 0, .false.)
    write(fid, *) wsum_mat(mat, ws, mat /= 0, .true.)
    write(fid, *) wsum(vec, w, vec /= 0, .true.)

    ! CALL SLEEP(1)
    call toc()

    ! mean
    call tic("[1.2 mat wmean] --------------")
    write(fid, *) wmean(mat)
    write(fid, *) wmean(mat, ws)
    write(fid, *) wmean(mat, ws, mat /= 0)
    call toc()
    ! print *, wsum(array)
    call toc

END PROGRAM

 ! [1.1 mat wsum] ---------------
 !   8.00000000
 !   4.50000000
 !   4.50000000
 !   4.50000000
 !   4.50000000
 !   5.14285707
 !   5.14285707
 !  elapsed:     169065.378743     169065.380559          0.001816
 ! [1.2 mat wmean] --------------
 !   1.33333337
 !  0.750000000
 !   1.12500000
 !  elapsed:     169065.380641     169065.380911          0.000270
 !  elapsed:     169065.380641     169065.380949          0.000308


      MODULE ERRORFLOW	!Calculate with an error estimate tagging along.
       INTEGER VSP,VMAX		!Do so with an arithmetic stack.
       PARAMETER (VMAX = 28)	!Surely sufficient.
       REAL STACKV(VMAX)	!Holds the values.
       REAL STACKE(VMAX)	!And the corresponding error estimate.
       INTEGER VOUT		!Output file.
       LOGICAL VTRACE		!Perhaps progress is to be followed in detail.
       DATA VSP,VOUT,VTRACE/0,0,.FALSE./	!Start with nothing.
       CHARACTER*1 PM			!I'm stuck with code page 437 instead of 850.
       PARAMETER (PM = CHAR(241))	!Thus ± does not yield this glyph on a "console" screen. CHAR(241) does.
       CONTAINS		!The servants.
        SUBROUTINE VINIT(OUT)	!Get ready.
         INTEGER OUT		!Unit number for output.
          VSP = 0		!My stack is empty.
          VOUT = OUT		!Save this rather than have extra parameters.
          VTRACE = VOUT .GT. 0	!By implication.
        END SUBROUTINE VINIT	!Ready.
        SUBROUTINE VSHOW(WOT)	!Show the topmost element.
         CHARACTER*(*) WOT	!The caller identifies itself.
          IF (VSP.LE.0) THEN	!Just in case
            WRITE (VOUT,1) "Empty",VSP	!My stack may be empty.
           ELSE			!But normally, it is not.
            IF (STACKV(VSP).EQ.0) THEN	!But it might have a zero value!
              WRITE (VOUT,1) WOT,VSP,STACKV(VSP),PM,STACKE(VSP)		!Alas. No percentage, then.
    1         FORMAT (A8,": Vstack(",I2,") =",F8.1,A1,F6.2,F9.1,"%")	!Suits the example.
             ELSE		!Avoiding a divide-by-zero is polite.
              WRITE (VOUT,1) WOT,VSP,STACKV(VSP),PM,STACKE(VSP),	!Possibly, a surprise, still.
     1         STACKE(VSP)/STACKV(VSP)*100	!The relative error may well be interesting.
            END IF		!The pearls have been cast.
          END IF		!So much for protection.
        END SUBROUTINE VSHOW	!Could reveal all the stack...

        SUBROUTINE VLOAD(V,E)	!Load the stack.
         REAL V,E		!The value and its error.
          IF (VSP.GE.VMAX) STOP "VLOAD: overflow!"	!Oh dear.
          VSP = VSP + 1		!Up one.
          STACKV(VSP) = V	!Place the value.
          STACKE(VSP) = E	!And the error.
          IF (VTRACE) CALL VSHOW("vLoad")
        END SUBROUTINE VLOAD	!That was easy!

        SUBROUTINE VADD		!Add the top two elements.
          IF (VSP.LE.1) STOP "VADD: underflow!"	!Maybe not.
          STACKV(VSP - 1) = STACKV(VSP - 1) + STACKV(VSP)	!Do the deed.
          STACKE(VSP - 1) = SQRT(STACKE(VSP - 1)**2 + STACKE(VSP)**2)	!The errors follow.
          VSP = VSP - 1			!Two values have become one.
          IF (VTRACE) CALL VSHOW("vAdd")!The result.
        END SUBROUTINE VADD	!The variance of the sum is the sum of the variances.

        SUBROUTINE VSUB		!Subtract the topmost element from the one below.
          IF (VSP.LE.1) STOP "VSUB: underflow!"	!Perhaps not.
          STACKV(VSP - 1) = STACKV(VSP - 1) - STACKV(VSP)	!The topmost was the second loaded.
          STACKE(VSP - 1) = SQRT(STACKE(VSP - 1)**2 + STACKE(VSP)**2)	!Add the variances also.
          VSP = VSP - 1			!Two values have become one.
          IF (VTRACE) CALL VSHOW("vSub")!The result.
        END SUBROUTINE VSUB	!Could alternatively play with the signs and add...

        SUBROUTINE VMUL		!Multiply the top two elements.
         REAL R1,R2		!Use relative errors in place of plain SD.
          IF (VSP.LE.1) STOP "VMUL: underflow!"	!Perhaps not.
          R1 = STACKE(VSP - 1)/STACKV(VSP - 1)	!The relative errors for multiply
          R2 = STACKE(VSP)    /STACKV(VSP)	!Are treated as are variances in addition.
          STACKV(VSP - 1) = STACKV(VSP - 1)*STACKV(VSP)	!Perform the multiply.
          VSP = VSP - 1					!Unstack, but not quite finished.
          STACKE(VSP) = SQRT((R1**2 + R2**2)*STACKV(VSP)**2)	![SD/xy]² =  [SD/x]² + [SD/y]²
          IF (VTRACE) CALL VSHOW("vMul")			!Thus SD² = [[SD/x]² + [SD/y]²]xy²
        END SUBROUTINE VMUL	!The square means that the error's sign is not altered.

        SUBROUTINE VDIV		!Divide the penultimate element by the top elements.
         REAL R1,R2		!Use relative errors in place of plain SD.
          IF (VSP.LE.1) STOP "VDIV: underflow!"	!Perhaps not.
          R1 = STACKE(VSP - 1)/STACKV(VSP - 1)	!The relative errors for divide
          R2 = STACKE(VSP)    /STACKV(VSP)	!Are treated as are variances in subtraction.
          STACKV(VSP - 1) = STACKV(VSP - 1)/STACKV(VSP)	!Perform the divide.
          VSP = VSP - 1					!X/Y is Load X, Load Y, Divide; Y is topmost.
          STACKE(VSP) = SQRT((R1**2 + R2**2)*STACKV(VSP)**2)	![SD/(x/y)]² =  [SD/x]² + [SD/y]²
          IF (VTRACE) CALL VSHOW("vDiv")			!Thus SD² = [[SD/x]² + [SD/y]²](x/y)²
        END SUBROUTINE VDIV	!Worry over y ± SD spanning zero...

        SUBROUTINE VSQRT	!Now for some fun with the topmost element.
          IF (VSP.LE.0) STOP "VSQRT: underflow!"	!Maybe not.
          STACKV(VSP) = SQRT(STACKV(VSP))		!Negative? Let the system complain.
          STACKE(VSP) = 0.5/STACKV(VSP)*STACKE(VSP)	!F(x ± s) = F(x) ± F'(x).s
          IF (VTRACE) CALL VSHOW("vSqrt")		!Here, F' can't be negative.
        END SUBROUTINE VSQRT	!No change to the pointer.
        SUBROUTINE VSQUARE	!Another raise-to-a-power.
          STACKE(VSP) = 2*ABS(STACKV(VSP))*STACKE(VSP)	!The error's sign is not to be messed with.
          STACKV(VSP) = STACKV(VSP)**2		!This will never be negative.
          IF (VTRACE) CALL VSHOW("vSquare")	!Keep away from zero though.
        END SUBROUTINE VSQUARE	!Same formula as VSQRT, just a different power.
        SUBROUTINE VPOW(P)	!Now for the more general.
         INTEGER P		!Though only integer powers for this routine, so no EXP(P*LN(x)).
          IF (VSP.LE.0) STOP "VPOW: underflow!"	!Perhaps not.
          IF (P.EQ.0)   STOP "VPOW: zero power!"	!No sense in this power!
          STACKE(VSP) = P*ABS(STACKV(VSP))**(P - 1)*STACKE(VSP)	!Negative values a worry.
          STACKV(VSP) = ABS(STACKV(VSP))**P			!I only want the magnitude.
          IF (VTRACE) CALL VSHOW("vPower")	!So, what happened?
        END SUBROUTINE VPOW	!Powers with fractional parts are troublesome.
      END MODULE ERRORFLOW	!That will do for the test problem.

      PROGRAM CALCULATE	!A distance, with error propagation.
      USE ERRORFLOW	!For the details.
      REAL X1, Y1, X2, Y2	!The co-ordinates.
      REAL X1E,Y1E,X2E,Y2E	!Their standard deviation.
      DATA X1, Y1 ,X2, Y2 /100., 50., 200.,100./	!Specified
      DATA X1E,Y1E,X2E,Y2E/  1.1, 1.2,  2.2, 2.3/	!Values.

      WRITE (6,1) X1,PM,X1E,Y1,PM,Y1E,	!Reveal the points
     1            X2,PM,X2E,Y2,PM,Y2E	!Though one could have used an array...
    1 FORMAT ("Euclidean distance between two points:"/	!A heading.
     1 ("(",F5.1,A1,F3.1,",",F5.1,A1,F3.1,")"))		!Thus, One point per line.

Calculate SQRT[(X2 - X1)**2 + (Y2 - Y1)**2]
      CALL VINIT(6)		!Start my arithmetic.
      CALL VLOAD(X2,X2E)
      CALL VLOAD(X1,X1E)
      CALL VSUB			!(X2 - X1)
      CALL VSQUARE		!(X2 - X1)**2
      CALL VLOAD(Y2,Y2E)
      CALL VLOAD(Y1,Y1E)
      CALL VSUB			!Y2 - Y1)
      CALL VSQUARE		!Y2 - Y1)**2
      CALL VADD			!(X2 - X1)**2 + (Y2 - Y1)**2
      CALL VSQRT		!SQRT((X2 - X1)**2 + (Y2 - Y1)**2)
      WRITE (6,2) STACKV(1),PM,STACKE(1)	!Ahh, the relief.
    2 FORMAT ("Distance",F6.1,A1,F4.2)	!Sizes to fit the example.
      END	!Enough.


      PROGRAM LA_SHESV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_HESV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, N, NRHS
!  .. "Local Arrays" ..
      INTEGER, ALLOCATABLE :: IPIV(:)
      COMPLEX(WP), ALLOCATABLE :: A(:,:), AA(:,:), B(:,:), BB(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'SHESV Example Program Results'
      N = 5; NRHS = 3
      WRITE(*,'(5H N = , I4, 9H; NRHS = , I4)') N, NRHS
      ALLOCATE ( A(N,N), AA(N,N), B(N,NRHS), BB(N,NRHS), IPIV(N) )

      OPEN(UNIT=21,FILE='hesv.ma',STATUS='UNKNOWN')
      DO I=1,N
         DO J=I,N
         READ(21,*) A(I,J);
         ENDDO
      ENDDO;
      CLOSE(21)

      WRITE(*,*) 'The matrix A :'
      DO I=1,N
      WRITE(*,"(5(I3,1X,'+',1X,I3,'i',1X))") INT(A(I,1)),INT(AIMAG(A(I,1))), &
                                             INT(A(I,2)),INT(AIMAG(A(I,2))), &
                                             INT(A(I,3)),INT(AIMAG(A(I,3))), &
                                             INT(A(I,4)),INT(AIMAG(A(I,4))), &
                                             INT(A(I,5)),INT(AIMAG(A(I,5)))
      ENDDO

      OPEN(UNIT=21,FILE='hesv.mb',STATUS='UNKNOWN')
      DO I=1,N
         READ(21,*) B(I,1);
      ENDDO;
      CLOSE(21)

      WRITE(*,*) 'The array B :'
      DO I=1,N
      WRITE(*,"((I3,1X,'+',1X,I3,'i',1X))") INT(B(I,1)),INT(AIMAG(B(I,1)))
      ENDDO

      BB=B
      WRITE(*,*)' CALL LA_HESV( A, B, IPIV=IPIV )'
      CALL LA_HESV( A, B, IPIV=IPIV )

      WRITE(*,*)'A on exit: '
      DO I=1,N; WRITE(*,*) A(I,:);
      ENDDO

      WRITE(*,*)'B on exit: '
      DO I=1,N; WRITE(*,*) (B(I,1));
      ENDDO

      WRITE(*,*)'IPIV on exit : ', IPIV

      END PROGRAM LA_SHESV_EXAMPLE


submodule(euler_interface_m) euler_prob_0017_m
    implicit none

contains

    module character(len=20) function euler0017()
        write (euler0017, "(i20)") ans()
    end function euler0017

    integer function ans()
        integer :: tot_c, i

        tot_c = 0
        do i = 1, 9
            tot_c = tot_c + count_letters(i)
        end do

        do i = 10, 19
            tot_c = tot_c + count_letters10(i)
        end do

        do i = 20, 99
            tot_c = tot_c + count_letters10(i)
        end do

        do i = 100, 999
            tot_c = tot_c + count_letters100(i)
        end do
        ans = tot_c + 11
    end function ans

    integer function count_letters(n)
        integer, intent(in) :: n
        integer :: temp

        select case (n)
        case (0)
            temp = 0
        case (1, 2, 6, 10)
            temp = 3
        case (4, 5, 9)
            temp = 4
        case (3, 7, 8, 40, 50, 60)
            temp = 5
        case (11, 12, 20, 30, 80, 90)
            temp = 6
        case (15, 16, 70)
            temp = 7
        case (13, 14, 18, 19)
            temp = 8
        case (17)
            temp = 9
        case (1000)
            temp = 8
        case default
            temp = 1000
        end select
        count_letters = temp
    end function count_letters

    integer function count_letters10(n)
        integer, intent(in) :: n
        integer :: d1, d2

        d1 = 0; d2 = 0
        if (count_letters(n) /= 1000) then
            count_letters10 = count_letters(n)
        else
            d1 = (n/10)*10
            d2 = n - d1
            count_letters10 = count_letters(d1) + count_letters(d2)
        end if

        if (n == 0) then
            count_letters10 = 0
        end if
    end function count_letters10

    integer function count_letters100(n)
        integer, intent(in) :: n
        integer :: d1, d2, hun, and

        hun = 7; and = 3
        if (mod(n, 100) == 0) then
            d1 = n/100
            count_letters100 = count_letters(d1) + hun
        else
            d1 = n/100
            d2 = n - (n/100)*100
            count_letters100 = count_letters(d1) + &
                               hun + and + count_letters10(d2)
        end if
    end function count_letters100

end submodule euler_prob_0017_m


      subroutine do_fft(a11, answer_mn, trigsu, trigsv, ifaxu, ifaxv,
     1   ntheta, nzeta, mbuse, nbuse)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use stel_kinds
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer ntheta, nzeta, mbuse, nbuse
      integer, dimension(*) :: ifaxu, ifaxv
      real(rprec), dimension(ntheta + 2,nzeta) :: a11
      real(rprec), dimension(3*ntheta/2 + 1) :: trigsu
      real(rprec), dimension(2*nzeta) :: trigsv
      complex(rprec), dimension(-mbuse:mbuse,0:nbuse) :: answer_mn
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec), parameter :: one = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: inc, jump, isign, jumpv, incv
      real(rprec), dimension(:), allocatable :: work11
      real(rprec) :: factor
C-----------------------------------------------

      allocate (work11(nzeta*(ntheta+2)))
c
c- Forward real to complex transform in the theta direction with index n.
c  i.e., integral of exp(-i*n*theta) * f(theta,zetah).
c
      inc = 1
      jump = ntheta + 2
      isign = -1

      call fft991(a11,work11,trigsu,ifaxu,inc,jump,ntheta,nzeta,isign)

c
c- now forward transform in the zetah direction with index m.
c  i.e., integral of exp(-i*m*zetah) * [theta transform of f(theta,zetah)]
c
      jumpv = 1
      incv = jump/2
      call cfft99(a11,work11,trigsv,ifaxv,incv,jumpv,nzeta,incv,isign)

      deallocate (work11)

c
c- Now reorganize and scale these to get the complex d(n,m)
c  FACTOR = 1 / (number of points used in the forward transform direction).
c  Because of (anti)symmetry, only nonnegative m values are needed.  We also
c  only fill to n = mbuse and m = nbuse since this is all that will be
c  used in the sums over n and m.
c
      factor = one/nzeta
c  store a11 in answer_mn array
      call reorganz (answer_mn, mbuse, nbuse, factor, a11, ntheta,
     1   nzeta)

      end subroutine do_fft


! Copyright 2012-2018, University of Strathclyde
! Authors: Lawrence T. Campbell
! License: BSD-3-Clause

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Module to apply noise to macroparticle positions in one dimension.

MODULE addNoise

use paratype
use randomGauss
use parallelInfoType
use macrosGen

implicit none

contains

subroutine applyNoise(x,dx,Nks)

! This routine adds noise to the macroparticle
! weight and phase space coordinate in each
! dimension.

  implicit none

!            ARGUMENTS

  real(kind=wp), intent(inout) :: x(:), Nks(:)
  real(kind=wp), intent(in) :: dx

!            LOCAL ARGS

  real(kind=wp) :: u
  real(kind=wp) :: sv
  integer(kind=ipl) :: k, Nm

  Nm = size(x)

  call init_random_seed()

  do k = 1,Nm

    sv = Nks(k)
    Nks(k) = random_Poisson(Nks(k), .TRUE.)
    if (Nks(k) <= 0.0_wp) then
      Nks(k) = sv
    else
      x(k)   = addxDev(x(k), dx, Nks(k), u)
    end if

  end do

end subroutine applyNoise

function addxDev(x,dx,Nk,u)

! This function adds on a random deviation to
! the coordinate x, based on Poisson stats and
! it's weight Nk (which is the number of
! macroparticles it represents).

  implicit none

!           ARGUMENTS

  real(kind=wp), intent(in)    ::  x, dx, Nk
  real(kind=wp), intent(out)   ::  u
  real(kind=wp) :: addxDev

!          LOCAL ARGS

  real(kind=wp) :: randomNum

  randomNum =   RandomNoGenerator(u)
  addxDev   =   x    +    (randomNum - 0.5_WP)  *  dx / SQRT(Nk)

end function addxDev

!!!!!!!!!!!!!!!!!!!!!!

END MODULE addNoise


!
!    Copyright 2011 Sebastian Heimann
!
!    Licensed under the Apache License, Version 2.0 (the "License");
!    you may not use this file except in compliance with the License.
!    You may obtain a copy of the License at
!
!        http://www.apache.org/licenses/LICENSE-2.0
!
!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.
!

module euler

! this module only provides a single method to initialize a rotation matrix
! given eulerian angles

    implicit none

    public init_euler

  contains

    pure subroutine init_euler( alpha, beta, gamma, mat )

      ! given the euler angles alpha,beta,gamma,
      ! make matrix mat a rotation matrix

      ! given coordinate system (x,y,z) and rotated system (xs,ys,zs)
      ! the line of nodes is the intersection between the x-y and the xs-ys
      ! planes.
      ! alpha is the angle between the z-axis and the zs-axis.
      ! beta is the angle between the x-axis and the line of nodes.
      ! gamma is the angle between the line of nodes and the xs-axis.

      ! Usage for moment tensors:
      !   real, dimension(3,3) :: m_unrot = reshape((/0,0,-1,0,0,0,-1,0,0/),(/3,3/))
      !   call init_euler(dip,strike,-rake, rotmat)
      !   m = matmul( rotmat, matmul( m_unrot, transpose(rotmat) ) )

        real, intent(in) :: alpha, beta, gamma
        real, intent(out), dimension(3,3) :: mat

        real :: ca,cb,cg,sa,sb,sg

        ca = cos(alpha)
        cb = cos(beta)
        cg = cos(gamma)
        sa = sin(alpha)
        sb = sin(beta)
        sg = sin(gamma)

        mat(1,1) = cb*cg-ca*sb*sg
        mat(2,1) = sb*cg+ca*cb*sg
        mat(3,1) = sa*sg
        mat(1,2) = -cb*sg-ca*sb*cg
        mat(2,2) = -sb*sg+ca*cb*cg
        mat(3,2) = sa*cg
        mat(1,3) = sa*sb
        mat(2,3) = -sa*cb
        mat(3,3) = ca

    end subroutine

end module


! test_decimal.f90 --
!     Test the decimal arithmeitc module
!
program test_timing
    use decimal_arithmetic
    implicit none

    real          :: value1, value2
    type(DECIMAL) :: x, y

    call print_decs

    x = real_to_dec(1.01)
    y = real_to_dec(1.21)

    write(*,*) 'Approximation via reals:'
    write(*,*) '1.01=', x
    write(*,*) '1.21=', y
    write(*,*) '1.01+1.21=', x+y
    write(*,*) '1.01-1.21=', x-y
    write(*,*) '1.01*1.21=', x*y

    write(*,*) 'Computations with decimals, defined directly:'
                 !123456789
    x = decimal(1, 10000000)
    y = decimal(1,210000000)

    write(*,*) '1.01=', x
    write(*,*) '1.21=', y
    write(*,*) '1.01+1.21=', x+y
    write(*,*) '1.01-1.21=', x-y
    write(*,*) '1.01*1.21=', x*y
    write(*,*) '1.01*1.21=', 1.01*1.21
    write(*,*) '(1.01*1.21)/1.21=', (x*y)/y

    write(*,*) 'x = ', dec_to_string(x)
    write(*,*) 'y = ', dec_to_string(y)
    write(*,*) 'z = ', dec_to_string(real_to_dec(1.23))

end program


SUBROUTINE SNDING (ZLS, Old_Ahum, temp, windsnd, timeloc, wind)
  use simsphere_mod
  implicit none

!TJC  real(kind=4),allocatable :: derivs(:)
  real,allocatable :: derivs(:)

  type(t_timeloc) :: timeloc
  type(t_temp) :: temp
  type(t_windsnd) :: windsnd
  type(t_wind) :: wind
  real :: EW(50)            ! Saturation vapor pressure at read-in sounding level, es (mb)
  real :: QS(50)            ! Specific humidity at read-in sounding level, q (g/g)
  real :: ZLS(50)           ! Height above station of read-in sounding level (m)
  real :: UCOMP(50), VCOMP(50), GMQ(50), Pot_Temp (50)
  real, dimension(:), allocatable :: ps, dep, dd0, ff0, zh

! Actual and decomposed values

! Put here -- Arrays to hold interpolated values [in COMMON at present]
! TD(50), QD(50), UD(50), VD(50)

  real :: Old_Ahum
  integer :: error

  integer :: NOBS_pTq, NOBS_wind, I, J, h
  real :: Station_Height, HEIGHT, TDEW, TBAR, THICK
! real :: Station_Height, HEIGHT, TDEW, TBAR
  real :: precip_H2O, sum_precip_H2O, dydx, dydxn, Pres_50, Pot_50
  real :: Height_at_NTRP

  deltaz = vert_spacing

! Get data from data structures instead of input file unit 9
! Temporary until subroutine calls, globals reworked
  station_height = timeloc%station_height
  dd0 = windsnd%dd0
  ff0 = windsnd%ff0
  zh = windsnd%zh
  ps = temp%ps
  ts = temp%ts
  dep = temp%dep
  ugs = wind%ugs
  vgs = wind%vgs

  nobs_ptq = size(ps)
  nobs_wind = size(dd0)

      WRITE(11,148) Station_Height*1000, UGS, VGS
148   FORMAT(/'   ***  Station Height and UGS/VGS  ***'// &
        'Station Height: ',F6.1,/, &
        'UGS,VGS: ',2F6.1)

      WRITE(11,'(/A/)') '   ***  Input Sounding  ***'

      WRITE(11,151) NOBS_pTq
151   FORMAT('Number of pressure levels: ',I3)
      WRITE(11,152) 'P:   ',(PS(I),I=1,NOBS_pTq)
      WRITE(11,152) 'T:   ',(TS(I),I=1,NOBS_pTq)
      WRITE(11,152) 'DEP: ',(DEP(I),I=1,NOBS_pTq)
152   FORMAT(A5,20F6.1)

      WRITE(11,153) NOBS_wind
153   FORMAT(/'Number of wind levels: ',I3)
      WRITE(11,152) 'HGT: ',(ZH(I),I=1,NOBS_wind)
      WRITE(11,152) 'DIR: ',(DD0(I),I=1,NOBS_wind)
      WRITE(11,154) 'SPD: ',(FF0(I),I=1,NOBS_wind)
154   FORMAT(A5,20F6.1)

! P/T/q first

  HEIGHT = 0.
  sum_precip_H2O = 0.

  do J = 1 , NOBS_pTq

    I = J - 1

    TDEW = TS(J) - DEP(J) + Celsius_to_Kelvin ! Dew Point (K)
    EW(J) = 6.11 * EXP((2.49E6 / 461.51)*(1 / Celsius_to_Kelvin - 1 / TDEW)) ! es (mb)
    QS(J) = 0.622 * EW(J) / PS(J) ! Specific Humidity (g/Kg)
    Pot_Temp(J) = (TS(J) + Celsius_to_Kelvin) * (1000. / PS(J)) ** 0.286 ! Theta (K)

    if (J > 1) then

      TBAR = (( TS(I) + TS(I+1) ) / 2 ) + Celsius_to_Kelvin ! Average Temperature (K)
      THICK = 287 * (TBAR / 9.8) * ALOG(PS(I) / PS(I+1)) ! Thickness (m)
      ! AAP: I don't think THICK needs to be passed on here.  windsnd%thick is
      ! AAP: used for the mixed layer thickness only.
      !windsnd%thick = thick
      HEIGHT = HEIGHT + THICK ! Height (above station) of pressure level
      ZLS(I+1) = HEIGHT
      GM(I) = ( Pot_Temp(I+1) - Pot_Temp(I) ) / THICK ! d(Theta)/dZ
      GMQ(I) = ( QS(I) - QS(I+1) ) / THICK ! d(q)/dZ

      precip_H2O = -0.622/GRAV*10.*((EW(J-1)*PS(J)-EW(J)*PS(J-1))*ALOG(PS(J)/PS(J-1))/(PS(J)-PS(J-1))+EW(J)-EW(J-1))
      sum_precip_H2O = sum_precip_H2O + precip_H2O
      omega = sum_precip_H2O
    end if
  end do

! Winds -- Note way winds are recorded by the weather service

  ZH(1) = 0.
  do i = 2, NOBS_wind
    ZH(i) = ((ZH(i) - Station_Height) * 1.0E3) / Ft_To_Metres
  end do

! Calculate u and v velocity components

  do J = 1 , NOBS_wind
    ucomp(j)=real((-FF0(j)*cos((90.-DD0(j))/radian))/Kts_To_Metres,4)
    vcomp(j)=real((-FF0(j)*sin((90.-DD0(j))/radian))/Kts_To_Metres,4)
  end do

! Number of levels it's possible to interpolate (NTRP) to are

  Height_at_NTRP = MIN(HEIGHT, ZH(NOBS_wind))
  NTRP = INT((Height_at_NTRP - 50.) / Vert_Spacing)

! Interpolate at 'h' height intervals using cubic splines.
! Numerical Recipes in FORTRAN -- pages 109, 110.

! 1.  Temperature

  allocate (derivs(NOBS_pTq), STAT = error)
  if (error /= 0) stop 'not enough memory'

! Calculate derivatives at the boundaries

  dydx = (Pot_Temp(2) - Pot_Temp(1)) / (ZLS(2) - ZLS(1))
  dydxn = (Pot_Temp(NOBS_pTq) - Pot_Temp(NOBS_pTq-1)) / &
          (ZLS(NOBS_pTq) - ZLS(NOBS_pTq-1))

! Calculate array of derivatives

  derivs=spline (ZLS, Pot_Temp, NOBS_pTq, dydx, dydxn)

! Call splint to get actual value at 50m and subsequent N metre intervals

  do i = 0, NTRP
    h = 50 + (Vert_Spacing * i)
    zi(i+1) = h
    TD(i+1) = splint (ZLS, Pot_Temp, derivs, NOBS_pTq, h)
  end do

! Free up space taken by the list of derivatives

  deallocate (derivs, STAT = error)

! 2. Moisture

  allocate (derivs(NOBS_pTq), STAT = error)
  if (error /= 0) stop 'not enough memory'

! Calculate derivatives at the boundaries

  dydx = (QS(2) - QS(1)) / (ZLS(2) - ZLS(1))
  dydxn = (QS(NOBS_pTq) - QS(NOBS_pTq-1)) / (ZLS(NOBS_pTq) - ZLS(NOBS_pTq-1))

! Calculate array of derivatives

  derivs=spline (ZLS, QS, NOBS_pTq, dydx, dydxn)

! Call splint to get actual value at 50m and subsequent N metre intervals

  do i = 0, NTRP
    h = 50 + (Vert_Spacing * i)
    QD(i+1) =  splint (ZLS, QS, derivs, NOBS_pTq, h)
  end do

! Free up space taken by the list of derivatives

  deallocate (derivs, STAT = error)

! 3. Winds

! Calculate the u component

! Create an array of REALS (floats) to put the dy/dx values into

  allocate (derivs(NOBS_wind), STAT = error)
  if (error /= 0) stop 'not enough memory'

! Calculate derivatives at the boundaries

  dydx = (ucomp(2) - ucomp(1)) / (ZH(2) - ZH(1))
  dydxn = (ucomp(NOBS_wind) - ucomp(NOBS_wind-1)) / &
              (ZH(NOBS_wind) - ZH(NOBS_wind-1))

! Calculate array of derivatives

  derivs=spline (ZH, ucomp, NOBS_wind, dydx, dydxn)

! Call splint to get actual value at 50m and subsequent 250m intervals

  do i = 0, NTRP
    h = 50 + (Vert_Spacing * i)
    UD(i+1) = splint (ZH, ucomp, derivs, NOBS_wind, h)
  end do

! Free up space taken by the list of derivatives

  deallocate (derivs, STAT = error)

! Do the same for v component

! Create an array of REALS (floats) to put the dy/dx values into

  allocate (derivs(NOBS_wind), STAT = error)
  if (error /= 0) stop 'not enough memory'

! Calculate derivatives at the boundaries

  dydx = (vcomp(2) - vcomp(1)) / (ZH(2) - ZH(1))
  dydxn = (vcomp(NOBS_wind) - vcomp(NOBS_wind-1)) / (ZH(NOBS_wind) - ZH(NOBS_wind-1))

! Calculate array of derivatives

  derivs=spline (ZH, vcomp, NOBS_wind, dydx, dydxn )

! Call splint to get actual value at 50m and subsequent 250m intervals

  do i = 0, NTRP
    h = 50 + (Vert_Spacing * i)
    VD(i+1) = splint (ZH, vcomp, derivs, NOBS_wind, h)
  end do

! Free up space taken by the list of derivatives

  deallocate (derivs, STAT = error)

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

! Calc lapse rate of temp in 1st layer and EW at screen level for
! use in the calc of screen level sat'n spec humidity.

  ATEMP = 50 * (TS(2) - TS(1)) / ZLS(2) + TS(1) + Celsius_to_Kelvin
  TSCREN = TS(1) + Celsius_to_Kelvin ! Screen Temperature
  EW = 6.11 * EXP (( 2.49E6 / 461.51 ) *(1 / Celsius_to_Kelvin - 1 / TSCREN))

  OSHUM = 0.622 * EW(1) / PS(1)
  AHUM = QS(1)
  Old_Ahum = QS(1)
  PS1 = PS(1)

! Changes 2/10/92

  Pres_50 = PS(1)*EXP(-9.8*50/(287* (TS(1) + Celsius_to_Kelvin)))
  Pot_50 = ATEMP * (1000 / Pres_50)** 0.286
  APTEMP = Pot_50
  O_Pot_Tmp = Pot_50
  Tdif_50 = Pot_50 - Atemp
  Tdif_s = Tdif_50 - 0.5

!        tdeww = tdew-Celsius_to_Kelvin
!        expt=7.5*tdeww/(237.3+tdeww)
!        eww = 6.11*10**expt
!        ewww = qs(j)*ps(j)/(0.378*qs(j)+0.622)

!        rhoa = ps(j)*100./(287.*tbar) ! Kell's Precip water calc
!        asum = asum + (qs(i) + qs(i+1))/2.*.001*rhoa*thick*100

! Write out the interpolated sounding

      WRITE(11,'(/A/)') '   ***  Interpolated Sounding  ***'

      WRITE(11,251) NTRP+1
251   FORMAT('Number of interpolated levels: ',I3)
      WRITE(11,249) 'ZI:  ',(NINT(ZI(I)),I=1,NTRP+1)
249   FORMAT(A5,3(20I6/))
      WRITE(11,252) 'TD:  ',(TD(I),I=1,NTRP+1)
252   FORMAT(A5,3(20F6.1/))
      WRITE(11,253) 'QD:  ',(1000.*QD(I),I=1,NTRP+1)
253   FORMAT(A5,3(20F6.1/))
      WRITE(11,252) 'UD:   ',(UD(I),I=1,NTRP+1)
      WRITE(11,254) 'VD:   ',(VD(I),I=1,NTRP+1)
254   FORMAT(A5,3(20F6.1/))

      WRITE (11,'(//A//)') '         ***  MODEL RESULTS  ***'

  return
end


module Mod_DoubleIndexMatmul

contains

function DoubleIndexMatmul(elmat,elunk)
   use typre
   implicit none
   real(rp), contiguous, target :: elmat(:,:,:,:), elunk(:,:)

   real(rp),allocatable, target :: DoubleIndexMatmul(:,:)

   real(rp), pointer :: auxelmat(:,:) => NULL(), auxelunk(:) => NULL(), auxelrhs(:) => NULL()
   integer(ip) :: matsize

   allocate(DoubleIndexMatmul(size(elunk,1),size(elunk,2)))

   matsize = size(elmat,1)*size(elmat,2)

   auxelmat(1:matsize,1:matsize) => elmat
   auxelrhs(1:matsize) => DoubleIndexMatmul
   auxelunk(1:matsize) => elunk

   auxelrhs = matmul(auxelmat,auxelunk)

end function

end module


 SUBROUTINE bmem14(a,b,bmem,t,nnode)

 !*** membrane matrix  Constant Strain Triangle

 IMPLICIT NONE

 INTEGER (kind=4), INTENT(IN) :: nnode
 REAL (kind=8), INTENT(IN) :: a(3),b(3),t(3,2)
 REAL (kind=8), INTENT(OUT) :: bmem(3,nnode,3)
 INTEGER (kind=4) :: j

 DO j=1,3          !node
   bmem(1:3,j,1) =  -b(j)*t(1:3,1)
   bmem(1:3,j,2) =   a(j)*t(1:3,2)
   bmem(1:3,j,3) =   a(j)*t(1:3,1)-b(j)*t(1:3,2)
 END DO

 RETURN
 END SUBROUTINE bmem14


	function clog(z1)
	complex clog, z1, z2
	dimension dummy(2)
	equivalence (a,z2,dummy(1)), (b,dummy(2))

	z2 = z1
	c = cabs(z2)
	b = atan2(b, a)
	a = alog(c)
	clog = z2
	return
	end


module mod_quadrature
#include <messenger.h>
    use mod_kinds,          only: rk,ik
    use mod_constants,      only: PI
    use type_quadrature,    only: quadrature_t
    implicit none

    ! Arrays of quadrature types, so an element can choose the order
    ! of the quadrature, based on it's polynomial approximation
    integer(ik), parameter :: ngq = 100

    type(quadrature_t), target, save :: GQ(ngq)

contains

    !>  Compute the number of quadrature nodes to use in order to accurately compute integrals
    !!  in the DG discretization. Based on solution and coordinate polynomial orders.
    !!
    !!  @author Nathan A. Wukie
    !!
    !!  @param[in] nterms_s     Number of terms in the solution expansion
    !!  @param[in] nterms_c     Number of terms in the coordinate expansion
    !!  @param[out] nnodes_face Number of quadrature nodes defined for a face
    !!  @param[out] nnodes_vol  Number of quadrature nodes defined for a volume
    !!
    !---------------------------------------------------------------------------------------
    subroutine compute_nnodes_gq(spacedim,nterms_s,nterms_c,nnodes_face,nnodes_vol)
        use mod_io,                     only: gq_rule
        integer(ik), intent(in)         :: spacedim
        integer(ik), intent(in)         :: nterms_s, nterms_c
        integer(ik), intent(out)        :: nnodes_face, nnodes_vol

        integer(ik)                     :: nterms1d, nnodes1d, nnodes2d, nnodes3d

        !
        ! Find number of terms in the 1d expansion
        !
        nterms1d = 0

        if ( spacedim == 3 ) then

            do while (nterms1d*nterms1d*nterms1d /= nterms_s)
                nterms1d = nterms1d + 1
            end do
            if (nterms1d*nterms1d*nterms1d > nterms_s) call chidg_signal(FATAL, "Incorrect number of terms counted when computing quadrature nodes")

        else if ( spacedim == 2 ) then

            do while (nterms1d*nterms1d /= nterms_s)
                nterms1d = nterms1d + 1
            end do
            if (nterms1d*nterms1d > nterms_s) call chidg_signal(FATAL, "Incorrect number of terms counted when computing quadrature nodes")

        else
            call chidg_signal(FATAL,"mod_quadrature: Invalid SPACEDIM")

        end if

        !
        ! Compute number of 1D nodes, based on integration rule
        !
        select case (gq_rule)
            case(1)
                !
                ! Collocation quadrature
                !
                nnodes1d = nterms1d
            case(2)
                nnodes1d = ceiling(3._rk*real(nterms1d,rk)/2._rk)
            case(3)
                nnodes1d = 2*nterms1d + 1
            case(4)
                nnodes1d = 3*nterms1d + 1
            case(5)
                nnodes1d = 5*nterms1d + 1
            case default
                call chidg_signal(FATAL, "compute_nnodes_integration: Value for gq_rule, specifying the rule for selecting number of quadrature points was not valid. Recognized values are gq_rule = (1, 2, 3)")

        end select

        !
        ! Compute face and volume nodes
        !
        nnodes2d = nnodes1d*nnodes1d
        nnodes3d = nnodes1d*nnodes1d*nnodes1d

        if ( SPACEDIM == 3 ) then
            nnodes_face = nnodes2d
            nnodes_vol  = nnodes3d
        else if ( SPACEDIM == 2 ) then
            nnodes_face = nnodes1d
            nnodes_vol  = nnodes2d
        else
            call chidg_signal(FATAL,"mod_quadrature: Invalid SPACEDIM")
        end if

    end subroutine compute_nnodes_gq
    !*************************************************************************************

    !>  Routine to find a quadrature instance or initialize a new one and return
    !!  its location in the global quadrature array 'igq' in GQ(igq)
    !!
    !!  @author Nathan A. Wukie
    !!
    !!  @param[in]      nterms  Number of terms in a polynomial expansion
    !!  @param[in]      nn_v    Number of volume quadrature nodes required
    !!  @param[in]      nn_f    Number of face quadrature nodes required
    !!  @param[inout]   gqout   Integer index of the selected quadrature instance in
    !!                          the global quadrature instance array, GQ
    !!
    !-------------------------------------------------------------------------------------
    subroutine get_quadrature(spacedim,nterms,nn_v,nn_f,gqout)
        integer(ik),    intent(in)      :: spacedim
        integer(ik),    intent(in)      :: nterms
        integer(ik),    intent(in)      :: nn_v
        integer(ik),    intent(in)      :: nn_f
        integer(ik),    intent(inout)   :: gqout

        integer(ik) :: igq
        logical     :: has_correct_nodes_terms
        logical     :: is_correct_spacedim

        !
        ! Loop through the quadrature instances that exist and get the index of one
        ! that matches the requirement.
        !
        do igq = 1,size(GQ)

            if (GQ(igq)%isInitialized) then
                !
                ! If we are here, check if the current GQ(igq) has the right terms and nodes.
                !
                has_correct_nodes_terms = (GQ(igq)%nterms == nterms) .and. &
                                          (GQ(igq)%nnodes_v == nn_v)
                is_correct_spacedim     = ( GQ(igq)%spacedim == spacedim )

                if (has_correct_nodes_terms .and. is_correct_spacedim) then
                    gqout = igq
                    exit
                end if

            else
                !
                ! If we are here, then no initialized GQ instance was found that met
                ! the requirements, so, we initialize a new one.
                !
                call GQ(igq)%init(spacedim,nn_f,nn_v,nterms)
                gqout = igq
                exit

            end if

        end do

    end subroutine get_quadrature
    !*************************************************************************************

end module mod_quadrature


c
c ---------------------------------------------------
c
       subroutine coarsen(valdub,midub,mjdub,mkdub,
     &                    valbgc,mi2tot,mj2tot,mk2tot,nvar)

       implicit double precision (a-h, o-z)

       dimension valdub(nvar,midub ,mjdub ,mkdub )
       dimension valbgc(nvar,mi2tot,mj2tot,mk2tot)

c :::::::::::::::::::::::: COARSEN ::::::::::::::::::::::::::::::::
c coarsen = coarsen the fine grid data (with double the usual
c           number of ghost cells to prepare coarsened
c           grid for error estimation.
c :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

       do 10 ivar = 1, nvar
       do 10 k = 1, mk2tot
       kfine = 2*(k-1) + 1
       do 10 j = 1, mj2tot
       jfine = 2*(j-1) + 1
       do 10 i = 1, mi2tot
       ifine = 2*(i-1) + 1
       valbgc(ivar,i,j,k) = (valdub(ivar,ifine  ,jfine  ,kfine  )
     &                      +valdub(ivar,ifine+1,jfine  ,kfine  )
     &                      +valdub(ivar,ifine  ,jfine+1,kfine  )
     &                      +valdub(ivar,ifine+1,jfine+1,kfine  )
     &                      +valdub(ivar,ifine  ,jfine  ,kfine+1)
     &                      +valdub(ivar,ifine+1,jfine  ,kfine+1)
     &                      +valdub(ivar,ifine  ,jfine+1,kfine+1)
     &                      +valdub(ivar,ifine+1,jfine+1,kfine+1))/8.d0
10     continue

       return
       end


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine input_Ac_2d
  use global_variables_2d
  implicit none
  integer :: it
  real(8) :: tt
  real(8) :: Es,Up,alpha

  allocate(Act_xyz(-1:Nt+2,3),jt_xyz(0:Nt+1,3))
  allocate(Act_pump_xyz(-1:Nt+2,3),Act_probe_xyz(-1:Nt+2,3))
  allocate(Act_pump(-1:Nt+2),Act_probe(-1:Nt+2) )

  E0_1=5.338d-9*sqrt(Iwcm2_1)
  omega_1 = omega_ev_1/(2d0*Ry)
  tpulse_1 = tpulse_fs_1/0.02418d0
  E0_2=5.338d-9*sqrt(Iwcm2_2)
  omega_2 = omega_ev_2/(2d0*Ry)
  tpulse_2 = tpulse_fs_2/0.02418d0
  Tdelay = Tdelay_fs/0.02418d0

!
  Es = piz_vc**2*E0_1**2/eps_g**3
  Up = E0_1**2/(4d0*mass_r*omega_1**2)
  alpha = (Es+Up)/eps_g

  write(*,"(A,2x,999e26.16e3)")"Stark shift, Es=",Es
  write(*,"(A,2x,999e26.16e3)")"Ponderomotive energy, Up=",Up
  write(*,"(A,2x,999e26.16e3)")"(Es+Up)/Eg=",(Es+Up)/eps_g
  write(*,"(A,2x,999e26.16e3)")"Es/Up=",Es/Up
  write(*,"(A,2x,999e26.16e3)")"E0_1=",E0_1
  write(*,"(A,2x,999e26.16e3)")"E0_2=",E0_2

  Act_xyz = 0d0; jt_xyz=0d0
  Act_pump = 0d0; Act_probe = 0d0

!Pump
  select case(envelope_1)
  case("cos4cos")
    do it = 0,Nt+1
      tt = dt*dble(it)
      if(abs(tt-0.5d0*tpulse_1) < 0.5d0*tpulse_1)then
        Act_pump(it) = -(E0_1/omega_1)*cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1)**4 &
          *sin(omega_1*(tt-0.5d0*tpulse_1)+2d0*pi*CEP_2pi_1)
      end if
    end do

  case("cos2cos")
    do it = 0,Nt+1
      tt = dt*dble(it)
      if(abs(tt-0.5d0*tpulse_1) < 0.5d0*tpulse_1)then
        Act_pump(it) = -(E0_1/omega_1)*cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1)**2 &
          *sin(omega_1*(tt-0.5d0*tpulse_1) +2d0*pi*CEP_2pi_1)
      end if
    end do

  case("cos6cos")
    do it = 0,Nt+1
      tt = dt*dble(it)
      if(abs(tt-0.5d0*tpulse_1) < 0.5d0*tpulse_1)then
        Act_pump(it) = -(E0_1/omega_1)*cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1)**6 &
          *sin(omega_1*(tt-0.5d0*tpulse_1)+2d0*pi*CEP_2pi_1)
      end if
    end do

  case default
    stop "Invalid envelope_1"
  end select

!Probe
  select case(envelope_2)
  case("cos4cos")
    do it = 0,Nt+1
      tt = dt*dble(it)

      if(abs(tt-0.5d0*tpulse_1-Tdelay) < 0.5d0*tpulse_2)then
        Act_probe(it) = -(E0_2/omega_2) &
          *cos(pi*(tt-0.5d0*tpulse_1-Tdelay)/tpulse_2)**4 &
          *sin(omega_2*(tt-0.5d0*tpulse_1-Tdelay)+2d0*pi*CEP_2pi_2)
      end if
    end do

  case("cos2cos")
    do it = 0,Nt+1
      tt = dt*dble(it)

      if(abs(tt-0.5d0*tpulse_1-Tdelay) < 0.5d0*tpulse_2)then
        Act_probe(it) = -(E0_2/omega_2) &
          *cos(pi*(tt-0.5d0*tpulse_1-Tdelay)/tpulse_2)**2 &
          *sin(omega_2*(tt-0.5d0*tpulse_1-Tdelay)+2d0*pi*CEP_2pi_2)
      end if
    end do

  case("cos6cos")
    do it = 0,Nt+1
      tt = dt*dble(it)

      if(abs(tt-0.5d0*tpulse_1-Tdelay) < 0.5d0*tpulse_2)then
        Act_probe(it) =  -(E0_2/omega_2) &
          *cos(pi*(tt-0.5d0*tpulse_1-Tdelay)/tpulse_2)**6 &
          *sin(omega_2*(tt-0.5d0*tpulse_1-Tdelay)+2d0*pi*CEP_2pi_2)
      end if
    end do

  case default
    stop "Invalid envelope_2"
  end select

  Act_pump_xyz(:,1) = dir_pol_1(1)*Act_pump(:)
  Act_pump_xyz(:,2) = dir_pol_1(2)*Act_pump(:)
  Act_pump_xyz(:,3) = dir_pol_1(3)*Act_pump(:)

  Act_probe_xyz(:,1) = dir_pol_2(1)*Act_probe(:)
  Act_probe_xyz(:,2) = dir_pol_2(2)*Act_probe(:)
  Act_probe_xyz(:,3) = dir_pol_2(3)*Act_probe(:)

  Act_xyz(:,:) =   Act_pump_xyz(:,:) + Act_probe_xyz(:,:)

  return
end subroutine input_Ac_2d


       SUBROUTINE W3FB06(ALAT,ALON,ALAT1,ALON1,DX,ALONV,XI,XJ)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM:  W3FB06        LAT/LON TO POLA (I,J) FOR GRIB
C   PRGMMR: STACKPOLE        ORG: NMC42       DATE:88-04-05
C
C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH GIVEN IN
C   THE NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE TO A GRID
C   COORDINATE SYSTEM OVERLAID ON A POLAR STEREOGRAPHIC MAP PRO-
C   JECTION TRUE AT 60 DEGREES N OR S LATITUDE. W3FB06 IS THE REVERSE
C   OF W3FB07. USES GRIB SPECIFICATION OF THE LOCATION OF THE GRID
C
C PROGRAM HISTORY LOG:
C   88-01-01  ORIGINAL AUTHOR:  STACKPOLE, W/NMC42
C   90-04-12  R.E.JONES   CONVERT TO CRAY CFT77 FORTRAN
C
C USAGE:  CALL W3FB06 (ALAT,ALON,ALAT1,ALON1,DX,ALONV,XI,XJ)
C   INPUT ARGUMENT LIST:
C     ALAT     - LATITUDE IN DEGREES (NEGATIVE IN SOUTHERN HEMIS)
C     ALON     - EAST LONGITUDE IN DEGREES, REAL*4
C     ALAT1    - LATITUDE  OF LOWER LEFT POINT OF GRID (POINT (1,1))
C     ALON1    - LONGITUDE OF LOWER LEFT POINT OF GRID (POINT (1,1))
C                ALL REAL*4
C     DX       - MESH LENGTH OF GRID IN METERS AT 60 DEG LAT
C                 MUST BE SET NEGATIVE IF USING
C                 SOUTHERN HEMISPHERE PROJECTION.
C                   190500.0 LFM GRID,
C                   381000.0 NH PE GRID, -381000.0 SH PE GRID, ETC.
C     ALONV    - THE ORIENTATION OF THE GRID.  I.E.,
C                THE EAST LONGITUDE VALUE OF THE VERTICAL MERIDIAN
C                WHICH IS PARALLEL TO THE Y-AXIS (OR COLUMNS OF
C                OF THE GRID)ALONG WHICH LATITUDE INCREASES AS
C                THE Y-COORDINATE INCREASES.  REAL*4
C                   FOR EXAMPLE:
C                   255.0 FOR LFM GRID,
C                   280.0 NH PE GRID, 100.0 SH PE GRID, ETC.
C
C   OUTPUT ARGUMENT LIST:
C     XI       - I COORDINATE OF THE POINT SPECIFIED BY ALAT, ALON
C     XJ       - J COORDINATE OF THE POINT; BOTH REAL*4
C
C   REMARKS: FORMULAE AND NOTATION LOOSELY BASED ON HOKE, HAYES,
C     AND RENNINGER'S "MAP PROJECTIONS AND GRID SYSTEMS...", MARCH 1981
C     AFGWC/TN-79/003
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
         DATA  RERTH /6.3712E+6/, PI/3.1416/
         DATA  SS60  /1.86603/
C
C        PRELIMINARY VARIABLES AND REDIFINITIONS
C
C        H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
C
C        REFLON IS LONGITUDE UPON WHICH THE POSITIVE X-COORDINATE
C        DRAWN THROUGH THE POLE AND TO THE RIGHT LIES
C        ROTATED AROUND FROM ORIENTATION (Y-COORDINATE) LONGITUDE
C        DIFFERENTLY IN EACH HEMISPHERE
C
         IF (DX.LT.0) THEN
           H      = -1.0
           DXL    = -DX
           REFLON = ALONV - 90.0
         ELSE
           H      = 1.0
           DXL    = DX
           REFLON = ALONV - 270.0
         ENDIF
C
         RADPD  = PI / 180.0
         REBYDX = RERTH/DXL
C
C        RADIUS TO LOWER LEFT HAND (LL) CORNER
C
         ALA1 =  ALAT1 * RADPD
         RMLL = REBYDX * COS(ALA1) * SS60/(1. + H * SIN(ALA1))
C
C        USE LL POINT INFO TO LOCATE POLE POINT
C
         ALO1  = (ALON1 - REFLON) * RADPD
         POLEI = 1. - RMLL * COS(ALO1)
         POLEJ = 1. - H * RMLL * SIN(ALO1)
C
C        RADIUS TO DESIRED POINT AND THE I J TOO
C
         ALA = ALAT   * RADPD
         RM  = REBYDX * COS(ALA) * SS60/(1. + H * SIN(ALA))
C
         ALO = (ALON - REFLON) * RADPD
         XI  = POLEI + RM * COS(ALO)
         XJ  = POLEJ + H * RM * SIN(ALO)
C
      RETURN
      END