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 ... file hrfft.f
c
c     this file contains a multiple fft package for spherepack. it
c     includes code and documentation for performing fast fourier
c     transforms (see subroutines hrffti,hrfftf and hrfftb)
c
c **********************************************************************
c
c     subroutine hrffti(n,wsave)
c
c     subroutine hrffti initializes the array wsave which is used in
c     both hrfftf and hrfftb. the prime factorization of n together
c     with a tabulation of the trigonometric functions are computed and
c     stored in wsave.
c
c     input parameter
c
c     n       the length of the sequence to be transformed.
c
c     output parameter
c
c     wsave   a work array which must be dimensioned at least 2*n+15.
c             the same work array can be used for both hrfftf and
c             hrfftb as long as n remains unchanged. different wsave
c             arrays are required for different values of n. the
c             contents of wsave must not be changed between calls
c             of hrfftf or hrfftb.
c
c **********************************************************************
c
c     subroutine hrfftf(m,n,r,mdimr,wsave,work)
c
c     subroutine hrfftf computes the fourier coefficients of m real
c     perodic sequences (fourier analysis); i.e. hrfftf computes the
c     real fft of m sequences each with length n. the transform is
c     defined below at output parameter r.
c
c     input parameters
c
c     m       the number of sequences.
c
c     n       the length of all m sequences.  the method is most
c             efficient when n is a product of small primes. n may
c             change as long as different work arrays are provided
c
c     r       r(m,n) is a two dimensional real array that contains m
c             sequences each with length n.
c
c     mdimr   the first dimension of the r array as it appears
c             in the program that calls hrfftf. mdimr must be
c             greater than or equal to m.
c
c
c     wsave   a work array with at least least 2*n+15 locations
c             in the program that calls hrfftf. the wsave array must be
c             initialized by calling subroutine hrffti(n,wsave) and a
c             different wsave array must be used for each different
c             value of n. this initialization does not have to be
c             repeated so long as n remains unchanged thus subsequent
c             transforms can be obtained faster than the first.
c             the same wsave array can be used by hrfftf and hrfftb.
c
c     work    a real work array with m*n locations.
c
c
c     output parameters
c
c     r      for all j=1,...,m
c
c             r(j,1) = the sum from i=1 to i=n of r(j,i)
c
c             if n is even set l =n/2   , if n is odd set l = (n+1)/2
c
c               then for k = 2,...,l
c
c                  r(j,2*k-2) = the sum from i = 1 to i = n of
c
c                       r(j,i)*cos((k-1)*(i-1)*2*pi/n)
c
c                  r(j,2*k-1) = the sum from i = 1 to i = n of
c
c                      -r(j,i)*sin((k-1)*(i-1)*2*pi/n)
c
c             if n is even
c
c                  r(j,n) = the sum from i = 1 to i = n of
c
c                       (-1)**(i-1)*r(j,i)
c
c      *****  note
c                  this transform is unnormalized since a call of hrfftf
c                  followed by a call of hrfftb will multiply the input
c                  sequence by n.
c
c     wsave   contains results which must not be destroyed between
c             calls of hrfftf or hrfftb.
c
c     work    a real work array with m*n locations that does
c             not have to be saved.
c
c **********************************************************************
c
c     subroutine hrfftb(m,n,r,mdimr,wsave,work)
c
c     subroutine hrfftb computes the real perodic sequence of m
c     sequences from their fourier coefficients (fourier synthesis).
c     the transform is defined below at output parameter r.
c
c     input parameters
c
c     m       the number of sequences.
c
c     n       the length of all m sequences.  the method is most
c             efficient when n is a product of small primes. n may
c             change as long as different work arrays are provided
c
c     r       r(m,n) is a two dimensional real array that contains
c             the fourier coefficients of m sequences each with
c             length n.
c
c     mdimr   the first dimension of the r array as it appears
c             in the program that calls hrfftb. mdimr must be
c             greater than or equal to m.
c
c     wsave   a work array which must be dimensioned at least 2*n+15.
c             in the program that calls hrfftb. the wsave array must be
c             initialized by calling subroutine hrffti(n,wsave) and a
c             different wsave array must be used for each different
c             value of n. this initialization does not have to be
c             repeated so long as n remains unchanged thus subsequent
c             transforms can be obtained faster than the first.
c             the same wsave array can be used by hrfftf and hrfftb.
c
c     work    a real work array with m*n locations.
c
c
c     output parameters
c
c     r      for all j=1,...,m
c
c             for n even and for i = 1,...,n
c
c                  r(j,i) = r(j,1)+(-1)**(i-1)*r(j,n)
c
c                       plus the sum from k=2 to k=n/2 of
c
c                        2.*r(j,2*k-2)*cos((k-1)*(i-1)*2*pi/n)
c
c                       -2.*r(j,2*k-1)*sin((k-1)*(i-1)*2*pi/n)
c
c             for n odd and for i = 1,...,n
c
c                  r(j,i) = r(j,1) plus the sum from k=2 to k=(n+1)/2 of
c
c                       2.*r(j,2*k-2)*cos((k-1)*(i-1)*2*pi/n)
c
c                      -2.*r(j,2*k-1)*sin((k-1)*(i-1)*2*pi/n)
c
c      *****  note
c                  this transform is unnormalized since a call of hrfftf
c                  followed by a call of hrfftb will multiply the input
c                  sequence by n.
c
c     wsave   contains results which must not be destroyed between
c             calls of hrfftb or hrfftf.
c
c     work    a real work array with m*n locations that does not
c             have to be saved
c
c **********************************************************************
c
c
c
      subroutine hrffti (n,wsave)
      implicit double precision (a-h,o-z)
      dimension       wsave(n+15)
      common /hrf/ tfft
      tfft = 0.d0
      if (n .eq. 1) return
      call hrfti1 (n,wsave(1),wsave(n+1))
      return
      end
      subroutine hrfti1 (n,wa,fac)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension       wa(n)      ,fac(15)    ,ntryh(4)
      double precision tpi,argh,argld,arg
      data ntryh(1),ntryh(2),ntryh(3),ntryh(4)/4,2,3,5/
      nl = n
      nf = 0
      j = 0
  101 j = j+1
      if (j-4) 102,102,103
  102 ntry = ntryh(j)
      go to 104
  103 ntry = ntry+2
  104 nq = nl/ntry
      nr = nl-ntry*nq
      if (nr) 101,105,101
  105 nf = nf+1
      fac(nf+2) = ntry
      nl = nq
      if (ntry .ne. 2) go to 107
      if (nf .eq. 1) go to 107
      do 106 i=2,nf
         ib = nf-i+2
         fac(ib+2) = fac(ib+1)
  106 continue
      fac(3) = 2
  107 if (nl .ne. 1) go to 104
      fac(1) = n
      fac(2) = nf
      tpi = 8.d0*datan(1.d0)
      argh = tpi/dfloat(n)
      is = 0
      nfm1 = nf-1
      l1 = 1
      if (nfm1 .eq. 0) return
      do 110 k1=1,nfm1
         ip = fac(k1+2)
         ld = 0
         l2 = l1*ip
         ido = n/l2
         ipm = ip-1
         do 109 j=1,ipm
            ld = ld+l1
            i = is
            argld = dfloat(ld)*argh
            fi = 0.d0
            do 108 ii=3,ido,2
               i = i+2
               fi = fi+1.d0
               arg = fi*argld
	       wa(i-1) = dcos(arg)
	       wa(i) = dsin(arg)
  108       continue
            is = is+ido
  109    continue
         l1 = l2
  110 continue
      return
      end
      subroutine hrfftf (m,n,r,mdimr,whrfft,work)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension       r(mdimr,n)  ,work(1)    ,whrfft(n+15)
      common /hrf/ tfft
      if (n .eq. 1) return
c     tstart = second(dum)
      call hrftf1 (m,n,r,mdimr,work,whrfft,whrfft(n+1))
c     tfft = tfft+second(dum)-tstart
      return
      end
      subroutine hrftf1 (m,n,c,mdimc,ch,wa,fac)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension       ch(m,n) ,c(mdimc,n)  ,wa(n)   ,fac(15)
      nf = fac(2)
      na = 1
      l2 = n
      iw = n
      do 111 k1=1,nf
         kh = nf-k1
         ip = fac(kh+3)
         l1 = l2/ip
         ido = n/l2
         idl1 = ido*l1
         iw = iw-(ip-1)*ido
         na = 1-na
         if (ip .ne. 4) go to 102
         ix2 = iw+ido
         ix3 = ix2+ido
         if (na .ne. 0) go to 101
	 call hradf4 (m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2),wa(ix3))
         go to 110
  101    call hradf4 (m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2),wa(ix3))
         go to 110
  102    if (ip .ne. 2) go to 104
         if (na .ne. 0) go to 103
	 call hradf2 (m,ido,l1,c,mdimc,ch,m,wa(iw))
         go to 110
  103    call hradf2 (m,ido,l1,ch,m,c,mdimc,wa(iw))
         go to 110
  104    if (ip .ne. 3) go to 106
         ix2 = iw+ido
         if (na .ne. 0) go to 105
	 call hradf3 (m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2))
         go to 110
  105    call hradf3 (m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2))
         go to 110
  106    if (ip .ne. 5) go to 108
         ix2 = iw+ido
         ix3 = ix2+ido
         ix4 = ix3+ido
         if (na .ne. 0) go to 107
      call hradf5(m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2),wa(ix3),wa(ix4))
         go to 110
  107 call hradf5(m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2),wa(ix3),wa(ix4))
         go to 110
  108    if (ido .eq. 1) na = 1-na
         if (na .ne. 0) go to 109
	 call hradfg (m,ido,ip,l1,idl1,c,c,c,mdimc,ch,ch,m,wa(iw))
         na = 1
         go to 110
  109    call hradfg (m,ido,ip,l1,idl1,ch,ch,ch,m,c,c,mdimc,wa(iw))
         na = 0
  110    l2 = l1
  111 continue
      if (na .eq. 1) return
      do 112 j=1,n
      do 112 i=1,m
	 c(i,j) = ch(i,j)
  112 continue
      return
      end
      subroutine hradf4 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1,wa2,wa3)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension    cc(mdimcc,ido,l1,4)   ,ch(mdimch,ido,4,l1)     ,
     1             wa1(ido)     ,wa2(ido)     ,wa3(ido)
      hsqt2=dsqrt(2.d0)/2.d0
      do 101 k=1,l1
         do 1001 m=1,mp
         ch(m,1,1,k) = (cc(m,1,k,2)+cc(m,1,k,4))
     1      +(cc(m,1,k,1)+cc(m,1,k,3))
         ch(m,ido,4,k) = (cc(m,1,k,1)+cc(m,1,k,3))
     1      -(cc(m,1,k,2)+cc(m,1,k,4))
         ch(m,ido,2,k) = cc(m,1,k,1)-cc(m,1,k,3)
         ch(m,1,3,k) = cc(m,1,k,4)-cc(m,1,k,2)
 1001    continue
  101 continue
      if (ido-2) 107,105,102
  102 idp2 = ido+2
      do 104 k=1,l1
         do 103 i=3,ido,2
            ic = idp2-i
            do 1003 m=1,mp
            ch(m,i-1,1,k) = ((wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*
     1       cc(m,i,k,2))+(wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*
     1       cc(m,i,k,4)))+(cc(m,i-1,k,1)+(wa2(i-2)*cc(m,i-1,k,3)+
     1       wa2(i-1)*cc(m,i,k,3)))
            ch(m,ic-1,4,k) = (cc(m,i-1,k,1)+(wa2(i-2)*cc(m,i-1,k,3)+
     1       wa2(i-1)*cc(m,i,k,3)))-((wa1(i-2)*cc(m,i-1,k,2)+
     1       wa1(i-1)*cc(m,i,k,2))+(wa3(i-2)*cc(m,i-1,k,4)+
     1       wa3(i-1)*cc(m,i,k,4)))
            ch(m,i,1,k) = ((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)*
     1       cc(m,i-1,k,2))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*
     1       cc(m,i-1,k,4)))+(cc(m,i,k,1)+(wa2(i-2)*cc(m,i,k,3)-
     1       wa2(i-1)*cc(m,i-1,k,3)))
            ch(m,ic,4,k) = ((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)*
     1       cc(m,i-1,k,2))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*
     1       cc(m,i-1,k,4)))-(cc(m,i,k,1)+(wa2(i-2)*cc(m,i,k,3)-
     1       wa2(i-1)*cc(m,i-1,k,3)))
            ch(m,i-1,3,k) = ((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)*
     1       cc(m,i-1,k,2))-(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*
     1       cc(m,i-1,k,4)))+(cc(m,i-1,k,1)-(wa2(i-2)*cc(m,i-1,k,3)+
     1       wa2(i-1)*cc(m,i,k,3)))
            ch(m,ic-1,2,k) = (cc(m,i-1,k,1)-(wa2(i-2)*cc(m,i-1,k,3)+
     1       wa2(i-1)*cc(m,i,k,3)))-((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)*
     1       cc(m,i-1,k,2))-(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*
     1       cc(m,i-1,k,4)))
            ch(m,i,3,k) = ((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*
     1       cc(m,i,k,4))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*
     1       cc(m,i,k,2)))+(cc(m,i,k,1)-(wa2(i-2)*cc(m,i,k,3)-
     1       wa2(i-1)*cc(m,i-1,k,3)))
            ch(m,ic,2,k) = ((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*
     1       cc(m,i,k,4))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*
     1       cc(m,i,k,2)))-(cc(m,i,k,1)-(wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*
     1       cc(m,i-1,k,3)))
 1003       continue
  103    continue
  104 continue
      if (mod(ido,2) .eq. 1) return
  105 continue
      do 106 k=1,l1
         do 1006 m=1,mp
            ch(m,ido,1,k) = (hsqt2*(cc(m,ido,k,2)-cc(m,ido,k,4)))+
     1       cc(m,ido,k,1)
            ch(m,ido,3,k) = cc(m,ido,k,1)-(hsqt2*(cc(m,ido,k,2)-
     1       cc(m,ido,k,4)))
            ch(m,1,2,k) = (-hsqt2*(cc(m,ido,k,2)+cc(m,ido,k,4)))-
     1       cc(m,ido,k,3)
            ch(m,1,4,k) = (-hsqt2*(cc(m,ido,k,2)+cc(m,ido,k,4)))+
     1       cc(m,ido,k,3)
 1006    continue
  106 continue
  107 return
      end
      subroutine hradf2 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension   ch(mdimch,ido,2,l1)  ,cc(mdimcc,ido,l1,2)     ,
     1                wa1(ido)
      do 101 k=1,l1
         do 1001 m=1,mp
         ch(m,1,1,k) = cc(m,1,k,1)+cc(m,1,k,2)
         ch(m,ido,2,k) = cc(m,1,k,1)-cc(m,1,k,2)
 1001    continue
  101 continue
      if (ido-2) 107,105,102
  102 idp2 = ido+2
      do 104 k=1,l1
         do 103 i=3,ido,2
            ic = idp2-i
            do 1003 m=1,mp
            ch(m,i,1,k) = cc(m,i,k,1)+(wa1(i-2)*cc(m,i,k,2)-
     1       wa1(i-1)*cc(m,i-1,k,2))
            ch(m,ic,2,k) = (wa1(i-2)*cc(m,i,k,2)-wa1(i-1)*
     1       cc(m,i-1,k,2))-cc(m,i,k,1)
            ch(m,i-1,1,k) = cc(m,i-1,k,1)+(wa1(i-2)*cc(m,i-1,k,2)+
     1       wa1(i-1)*cc(m,i,k,2))
            ch(m,ic-1,2,k) = cc(m,i-1,k,1)-(wa1(i-2)*cc(m,i-1,k,2)+
     1       wa1(i-1)*cc(m,i,k,2))
 1003       continue
  103    continue
  104 continue
      if (mod(ido,2) .eq. 1) return
  105 do 106 k=1,l1
         do 1006 m=1,mp
         ch(m,1,2,k) = -cc(m,ido,k,2)
         ch(m,ido,1,k) = cc(m,ido,k,1)
 1006    continue
  106 continue
  107 return
      end
      subroutine hradf3 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1,wa2)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension   ch(mdimch,ido,3,l1)  ,cc(mdimcc,ido,l1,3)     ,
     1                wa1(ido)     ,wa2(ido)
      arg=2.d0*pimach()/3.d0
      taur=dcos(arg)
      taui=dsin(arg)
      do 101 k=1,l1
         do 1001 m=1,mp
         ch(m,1,1,k) = cc(m,1,k,1)+(cc(m,1,k,2)+cc(m,1,k,3))
         ch(m,1,3,k) = taui*(cc(m,1,k,3)-cc(m,1,k,2))
         ch(m,ido,2,k) = cc(m,1,k,1)+taur*
     1      (cc(m,1,k,2)+cc(m,1,k,3))
 1001    continue
  101 continue
      if (ido .eq. 1) return
      idp2 = ido+2
      do 103 k=1,l1
         do 102 i=3,ido,2
            ic = idp2-i
            do 1002 m=1,mp
            ch(m,i-1,1,k) = cc(m,i-1,k,1)+((wa1(i-2)*cc(m,i-1,k,2)+
     1       wa1(i-1)*cc(m,i,k,2))+(wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*
     1       cc(m,i,k,3)))
            ch(m,i,1,k) = cc(m,i,k,1)+((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)*
     1       cc(m,i-1,k,2))+(wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*
     1       cc(m,i-1,k,3)))
            ch(m,i-1,3,k) = (cc(m,i-1,k,1)+taur*((wa1(i-2)*
     1       cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2))+(wa2(i-2)*
     1       cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3))))+(taui*((wa1(i-2)*
     1       cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2))-(wa2(i-2)*
     1       cc(m,i,k,3)-wa2(i-1)*cc(m,i-1,k,3))))
            ch(m,ic-1,2,k) = (cc(m,i-1,k,1)+taur*((wa1(i-2)*
     1       cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2))+(wa2(i-2)*
     1       cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3))))-(taui*((wa1(i-2)*
     1       cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2))-(wa2(i-2)*
     1       cc(m,i,k,3)-wa2(i-1)*cc(m,i-1,k,3))))
            ch(m,i,3,k) = (cc(m,i,k,1)+taur*((wa1(i-2)*cc(m,i,k,2)-
     1       wa1(i-1)*cc(m,i-1,k,2))+(wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*
     1       cc(m,i-1,k,3))))+(taui*((wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*
     1       cc(m,i,k,3))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*
     1       cc(m,i,k,2))))
            ch(m,ic,2,k) = (taui*((wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*
     1       cc(m,i,k,3))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*
     1       cc(m,i,k,2))))-(cc(m,i,k,1)+taur*((wa1(i-2)*cc(m,i,k,2)-
     1       wa1(i-1)*cc(m,i-1,k,2))+(wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*
     1       cc(m,i-1,k,3))))
 1002       continue
  102    continue
  103 continue
      return
      end
      subroutine hradf5 (mp,ido,l1,cc,mdimcc,ch,mdimch,
     1                   wa1,wa2,wa3,wa4)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension  cc(mdimcc,ido,l1,5)    ,ch(mdimch,ido,5,l1)     ,
     1           wa1(ido)     ,wa2(ido)     ,wa3(ido)     ,wa4(ido)
      arg=2.d0*pimach()/5.d0
      tr11=dcos(arg)
      ti11=dsin(arg)
      tr12=dcos(2.d0*arg)
      ti12=dsin(2.d0*arg)
      do 101 k=1,l1
         do 1001 m=1,mp
         ch(m,1,1,k) = cc(m,1,k,1)+(cc(m,1,k,5)+cc(m,1,k,2))+
     1    (cc(m,1,k,4)+cc(m,1,k,3))
         ch(m,ido,2,k) = cc(m,1,k,1)+tr11*(cc(m,1,k,5)+cc(m,1,k,2))+
     1    tr12*(cc(m,1,k,4)+cc(m,1,k,3))
         ch(m,1,3,k) = ti11*(cc(m,1,k,5)-cc(m,1,k,2))+ti12*
     1    (cc(m,1,k,4)-cc(m,1,k,3))
         ch(m,ido,4,k) = cc(m,1,k,1)+tr12*(cc(m,1,k,5)+cc(m,1,k,2))+
     1    tr11*(cc(m,1,k,4)+cc(m,1,k,3))
         ch(m,1,5,k) = ti12*(cc(m,1,k,5)-cc(m,1,k,2))-ti11*
     1    (cc(m,1,k,4)-cc(m,1,k,3))
 1001    continue
  101 continue
      if (ido .eq. 1) return
      idp2 = ido+2
      do 103 k=1,l1
         do 102 i=3,ido,2
            ic = idp2-i
            do 1002 m=1,mp
            ch(m,i-1,1,k) = cc(m,i-1,k,1)+((wa1(i-2)*cc(m,i-1,k,2)+
     1       wa1(i-1)*cc(m,i,k,2))+(wa4(i-2)*cc(m,i-1,k,5)+wa4(i-1)*
     1       cc(m,i,k,5)))+((wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*
     1       cc(m,i,k,3))+(wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*cc(m,i,k,4)))
            ch(m,i,1,k) = cc(m,i,k,1)+((wa1(i-2)*cc(m,i,k,2)-wa1(i-1)*
     1       cc(m,i-1,k,2))+(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)*
     1       cc(m,i-1,k,5)))+((wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*
     1       cc(m,i-1,k,3))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*
     1       cc(m,i-1,k,4)))
            ch(m,i-1,3,k) = cc(m,i-1,k,1)+tr11*
     1      ( wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2)
     1       +wa4(i-2)*cc(m,i-1,k,5)+wa4(i-1)*cc(m,i,k,5))+tr12*
     1      ( wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3)
     1       +wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*cc(m,i,k,4))+ti11*
     1      ( wa1(i-2)*cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2)
     1       -(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)*cc(m,i-1,k,5)))+ti12*
     1      ( wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*cc(m,i-1,k,3)
     1       -(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*cc(m,i-1,k,4)))
            ch(m,ic-1,2,k) = cc(m,i-1,k,1)+tr11*
     1      ( wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2)
     1       +wa4(i-2)*cc(m,i-1,k,5)+wa4(i-1)*cc(m,i,k,5))+tr12*
     1     ( wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3)
     1      +wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*cc(m,i,k,4))-(ti11*
     1      ( wa1(i-2)*cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2)
     1       -(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)*cc(m,i-1,k,5)))+ti12*
     1      ( wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*cc(m,i-1,k,3)
     1       -(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*cc(m,i-1,k,4))))
            ch(m,i,3,k) = (cc(m,i,k,1)+tr11*((wa1(i-2)*cc(m,i,k,2)-
     1       wa1(i-1)*cc(m,i-1,k,2))+(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)*
     1       cc(m,i-1,k,5)))+tr12*((wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*
     1       cc(m,i-1,k,3))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*
     1       cc(m,i-1,k,4))))+(ti11*((wa4(i-2)*cc(m,i-1,k,5)+
     1       wa4(i-1)*cc(m,i,k,5))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*
     1       cc(m,i,k,2)))+ti12*((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*
     1       cc(m,i,k,4))-(wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*
     1       cc(m,i,k,3))))
            ch(m,ic,2,k) = (ti11*((wa4(i-2)*cc(m,i-1,k,5)+wa4(i-1)*
     1       cc(m,i,k,5))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*
     1       cc(m,i,k,2)))+ti12*((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*
     1       cc(m,i,k,4))-(wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*
     1       cc(m,i,k,3))))-(cc(m,i,k,1)+tr11*((wa1(i-2)*cc(m,i,k,2)-
     1       wa1(i-1)*cc(m,i-1,k,2))+(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)*
     1       cc(m,i-1,k,5)))+tr12*((wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*
     1       cc(m,i-1,k,3))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*
     1       cc(m,i-1,k,4))))
            ch(m,i-1,5,k) = (cc(m,i-1,k,1)+tr12*((wa1(i-2)*
     1       cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2))+(wa4(i-2)*
     1       cc(m,i-1,k,5)+wa4(i-1)*cc(m,i,k,5)))+tr11*((wa2(i-2)*
     1       cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3))+(wa3(i-2)*
     1       cc(m,i-1,k,4)+wa3(i-1)*cc(m,i,k,4))))+(ti12*((wa1(i-2)*
     1       cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2))-(wa4(i-2)*cc(m,i,k,5)-
     1       wa4(i-1)*cc(m,i-1,k,5)))-ti11*((wa2(i-2)*cc(m,i,k,3)-
     1       wa2(i-1)*cc(m,i-1,k,3))-(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*
     1       cc(m,i-1,k,4))))
            ch(m,ic-1,4,k) = (cc(m,i-1,k,1)+tr12*((wa1(i-2)*
     1       cc(m,i-1,k,2)+wa1(i-1)*cc(m,i,k,2))+(wa4(i-2)*
     1       cc(m,i-1,k,5)+wa4(i-1)*cc(m,i,k,5)))+tr11*((wa2(i-2)*
     1       cc(m,i-1,k,3)+wa2(i-1)*cc(m,i,k,3))+(wa3(i-2)*
     1       cc(m,i-1,k,4)+wa3(i-1)*cc(m,i,k,4))))-(ti12*((wa1(i-2)*
     1       cc(m,i,k,2)-wa1(i-1)*cc(m,i-1,k,2))-(wa4(i-2)*cc(m,i,k,5)-
     1       wa4(i-1)*cc(m,i-1,k,5)))-ti11*((wa2(i-2)*cc(m,i,k,3)-
     1       wa2(i-1)*cc(m,i-1,k,3))-(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*
     1       cc(m,i-1,k,4))))
            ch(m,i,5,k) = (cc(m,i,k,1)+tr12*((wa1(i-2)*cc(m,i,k,2)-
     1       wa1(i-1)*cc(m,i-1,k,2))+(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)*
     1       cc(m,i-1,k,5)))+tr11*((wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*
     1       cc(m,i-1,k,3))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*
     1       cc(m,i-1,k,4))))+(ti12*((wa4(i-2)*cc(m,i-1,k,5)+
     1       wa4(i-1)*cc(m,i,k,5))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*
     1       cc(m,i,k,2)))-ti11*((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*
     1       cc(m,i,k,4))-(wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*
     1       cc(m,i,k,3))))
            ch(m,ic,4,k) = (ti12*((wa4(i-2)*cc(m,i-1,k,5)+wa4(i-1)*
     1       cc(m,i,k,5))-(wa1(i-2)*cc(m,i-1,k,2)+wa1(i-1)*
     1       cc(m,i,k,2)))-ti11*((wa3(i-2)*cc(m,i-1,k,4)+wa3(i-1)*
     1       cc(m,i,k,4))-(wa2(i-2)*cc(m,i-1,k,3)+wa2(i-1)*
     1       cc(m,i,k,3))))-(cc(m,i,k,1)+tr12*((wa1(i-2)*cc(m,i,k,2)-
     1       wa1(i-1)*cc(m,i-1,k,2))+(wa4(i-2)*cc(m,i,k,5)-wa4(i-1)*
     1       cc(m,i-1,k,5)))+tr11*((wa2(i-2)*cc(m,i,k,3)-wa2(i-1)*
     1       cc(m,i-1,k,3))+(wa3(i-2)*cc(m,i,k,4)-wa3(i-1)*
     1       cc(m,i-1,k,4))))
 1002       continue
  102    continue
  103 continue
      return
      end
      subroutine hradfg (mp,ido,ip,l1,idl1,cc,c1,c2,mdimcc,
     1              ch,ch2,mdimch,wa)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension     ch(mdimch,ido,l1,ip)   ,cc(mdimcc,ido,ip,l1)  ,
     1            c1(mdimcc,ido,l1,ip)    ,c2(mdimcc,idl1,ip),
     2                ch2(mdimch,idl1,ip)           ,wa(ido)
      tpi=2.d0*pimach()
      arg = tpi/dfloat(ip)
      dcp = dcos(arg)
      dsp = dsin(arg)
      ipph = (ip+1)/2
      ipp2 = ip+2
      idp2 = ido+2
      nbd = (ido-1)/2
      if (ido .eq. 1) go to 119
      do 101 ik=1,idl1
         do 1001 m=1,mp
         ch2(m,ik,1) = c2(m,ik,1)
 1001    continue
  101 continue
      do 103 j=2,ip
         do 102 k=1,l1
            do 1002 m=1,mp
            ch(m,1,k,j) = c1(m,1,k,j)
 1002       continue
  102    continue
  103 continue
      if (nbd .gt. l1) go to 107
      is = -ido
      do 106 j=2,ip
         is = is+ido
         idij = is
         do 105 i=3,ido,2
            idij = idij+2
            do 104 k=1,l1
               do 1004 m=1,mp
               ch(m,i-1,k,j) = wa(idij-1)*c1(m,i-1,k,j)+wa(idij)
     1           *c1(m,i,k,j)
               ch(m,i,k,j) = wa(idij-1)*c1(m,i,k,j)-wa(idij)
     1           *c1(m,i-1,k,j)
 1004          continue
  104       continue
  105    continue
  106 continue
      go to 111
  107 is = -ido
      do 110 j=2,ip
         is = is+ido
         do 109 k=1,l1
            idij = is
            do 108 i=3,ido,2
               idij = idij+2
               do 1008 m=1,mp
               ch(m,i-1,k,j) = wa(idij-1)*c1(m,i-1,k,j)+wa(idij)
     1           *c1(m,i,k,j)
               ch(m,i,k,j) = wa(idij-1)*c1(m,i,k,j)-wa(idij)
     1           *c1(m,i-1,k,j)
 1008          continue
  108       continue
  109    continue
  110 continue
  111 if (nbd .lt. l1) go to 115
      do 114 j=2,ipph
         jc = ipp2-j
         do 113 k=1,l1
            do 112 i=3,ido,2
               do 1012 m=1,mp
               c1(m,i-1,k,j) = ch(m,i-1,k,j)+ch(m,i-1,k,jc)
               c1(m,i-1,k,jc) = ch(m,i,k,j)-ch(m,i,k,jc)
               c1(m,i,k,j) = ch(m,i,k,j)+ch(m,i,k,jc)
               c1(m,i,k,jc) = ch(m,i-1,k,jc)-ch(m,i-1,k,j)
 1012          continue
  112       continue
  113    continue
  114 continue
      go to 121
  115 do 118 j=2,ipph
         jc = ipp2-j
         do 117 i=3,ido,2
            do 116 k=1,l1
               do 1016 m=1,mp
               c1(m,i-1,k,j) = ch(m,i-1,k,j)+ch(m,i-1,k,jc)
               c1(m,i-1,k,jc) = ch(m,i,k,j)-ch(m,i,k,jc)
               c1(m,i,k,j) = ch(m,i,k,j)+ch(m,i,k,jc)
               c1(m,i,k,jc) = ch(m,i-1,k,jc)-ch(m,i-1,k,j)
 1016          continue
  116       continue
  117    continue
  118 continue
      go to 121
  119 do 120 ik=1,idl1
         do 1020 m=1,mp
         c2(m,ik,1) = ch2(m,ik,1)
 1020    continue
  120 continue
  121 do 123 j=2,ipph
         jc = ipp2-j
         do 122 k=1,l1
            do 1022 m=1,mp
            c1(m,1,k,j) = ch(m,1,k,j)+ch(m,1,k,jc)
            c1(m,1,k,jc) = ch(m,1,k,jc)-ch(m,1,k,j)
 1022       continue
  122    continue
  123 continue
c
      ar1 = 1.d0
      ai1 = 0.d0
      do 127 l=2,ipph
         lc = ipp2-l
         ar1h = dcp*ar1-dsp*ai1
         ai1 = dcp*ai1+dsp*ar1
         ar1 = ar1h
         do 124 ik=1,idl1
            do 1024 m=1,mp
            ch2(m,ik,l) = c2(m,ik,1)+ar1*c2(m,ik,2)
            ch2(m,ik,lc) = ai1*c2(m,ik,ip)
 1024       continue
  124    continue
         dc2 = ar1
         ds2 = ai1
         ar2 = ar1
         ai2 = ai1
         do 126 j=3,ipph
            jc = ipp2-j
            ar2h = dc2*ar2-ds2*ai2
            ai2 = dc2*ai2+ds2*ar2
            ar2 = ar2h
            do 125 ik=1,idl1
               do 1025 m=1,mp
               ch2(m,ik,l) = ch2(m,ik,l)+ar2*c2(m,ik,j)
               ch2(m,ik,lc) = ch2(m,ik,lc)+ai2*c2(m,ik,jc)
 1025          continue
  125       continue
  126    continue
  127 continue
      do 129 j=2,ipph
         do 128 ik=1,idl1
            do 1028 m=1,mp
            ch2(m,ik,1) = ch2(m,ik,1)+c2(m,ik,j)
 1028       continue
  128    continue
  129 continue
c
      if (ido .lt. l1) go to 132
      do 131 k=1,l1
         do 130 i=1,ido
            do 1030 m=1,mp
            cc(m,i,1,k) = ch(m,i,k,1)
 1030       continue
  130    continue
  131 continue
      go to 135
  132 do 134 i=1,ido
         do 133 k=1,l1
            do 1033 m=1,mp
            cc(m,i,1,k) = ch(m,i,k,1)
 1033       continue
  133    continue
  134 continue
  135 do 137 j=2,ipph
         jc = ipp2-j
         j2 = j+j
         do 136 k=1,l1
            do 1036 m=1,mp
            cc(m,ido,j2-2,k) = ch(m,1,k,j)
            cc(m,1,j2-1,k) = ch(m,1,k,jc)
 1036       continue
  136    continue
  137 continue
      if (ido .eq. 1) return
      if (nbd .lt. l1) go to 141
      do 140 j=2,ipph
         jc = ipp2-j
         j2 = j+j
         do 139 k=1,l1
            do 138 i=3,ido,2
               ic = idp2-i
               do 1038 m=1,mp
               cc(m,i-1,j2-1,k) = ch(m,i-1,k,j)+ch(m,i-1,k,jc)
               cc(m,ic-1,j2-2,k) = ch(m,i-1,k,j)-ch(m,i-1,k,jc)
               cc(m,i,j2-1,k) = ch(m,i,k,j)+ch(m,i,k,jc)
               cc(m,ic,j2-2,k) = ch(m,i,k,jc)-ch(m,i,k,j)
 1038          continue
  138       continue
  139    continue
  140 continue
      return
  141 do 144 j=2,ipph
         jc = ipp2-j
         j2 = j+j
         do 143 i=3,ido,2
            ic = idp2-i
            do 142 k=1,l1
               do 1042 m=1,mp
               cc(m,i-1,j2-1,k) = ch(m,i-1,k,j)+ch(m,i-1,k,jc)
               cc(m,ic-1,j2-2,k) = ch(m,i-1,k,j)-ch(m,i-1,k,jc)
               cc(m,i,j2-1,k) = ch(m,i,k,j)+ch(m,i,k,jc)
               cc(m,ic,j2-2,k) = ch(m,i,k,jc)-ch(m,i,k,j)
 1042          continue
  142       continue
  143    continue
  144 continue
      return
      end
      double precision function pimach()
      implicit double precision (a-h,o-z)
      pimach=3.14159265358979323846264338328d0
      return
      end
      subroutine hrfftb(m,n,r,mdimr,whrfft,work)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension     r(mdimr,n)  ,work(1)    ,whrfft(n+15)
      common /hrf/ tfft
      if (n .eq. 1) return
c     tstart = second(dum)
      call hrftb1 (m,n,r,mdimr,work,whrfft,whrfft(n+1))
c     tfft = tfft+second(dum)-tstart
      return
      end
      subroutine hrftb1 (m,n,c,mdimc,ch,wa,fac)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension       ch(m,n), c(mdimc,n), wa(n) ,fac(15)
      nf = fac(2)
      na = 0
      l1 = 1
      iw = 1
      do 116 k1=1,nf
         ip = fac(k1+2)
         l2 = ip*l1
         ido = n/l2
         idl1 = ido*l1
         if (ip .ne. 4) go to 103
         ix2 = iw+ido
         ix3 = ix2+ido
         if (na .ne. 0) go to 101
	 call hradb4 (m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2),wa(ix3))
         go to 102
  101    call hradb4 (m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2),wa(ix3))
  102    na = 1-na
         go to 115
  103    if (ip .ne. 2) go to 106
         if (na .ne. 0) go to 104
	 call hradb2 (m,ido,l1,c,mdimc,ch,m,wa(iw))
         go to 105
  104    call hradb2 (m,ido,l1,ch,m,c,mdimc,wa(iw))
  105    na = 1-na
         go to 115
  106    if (ip .ne. 3) go to 109
         ix2 = iw+ido
         if (na .ne. 0) go to 107
	 call hradb3 (m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2))
         go to 108
  107    call hradb3 (m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2))
  108    na = 1-na
         go to 115
  109    if (ip .ne. 5) go to 112
         ix2 = iw+ido
         ix3 = ix2+ido
         ix4 = ix3+ido
         if (na .ne. 0) go to 110
      call hradb5 (m,ido,l1,c,mdimc,ch,m,wa(iw),wa(ix2),wa(ix3),wa(ix4))
         go to 111
  110 call hradb5 (m,ido,l1,ch,m,c,mdimc,wa(iw),wa(ix2),wa(ix3),wa(ix4))
  111    na = 1-na
         go to 115
  112    if (na .ne. 0) go to 113
	 call hradbg (m,ido,ip,l1,idl1,c,c,c,mdimc,ch,ch,m,wa(iw))
         go to 114
  113    call hradbg (m,ido,ip,l1,idl1,ch,ch,ch,m,c,c,mdimc,wa(iw))
  114    if (ido .eq. 1) na = 1-na
  115    l1 = l2
         iw = iw+(ip-1)*ido
  116 continue
      if (na .eq. 0) return
      do 117 j=1,n
      do 117 i=1,m
	 c(i,j) = ch(i,j)
  117 continue
      return
      end
      subroutine hradbg (mp,ido,ip,l1,idl1,cc,c1,c2,mdimcc,
     1          ch,ch2,mdimch,wa)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension    ch(mdimch,ido,l1,ip)    ,cc(mdimcc,ido,ip,l1) ,
     1           c1(mdimcc,ido,l1,ip)     ,c2(mdimcc,idl1,ip),
     2                ch2(mdimch,idl1,ip)       ,wa(ido)
      tpi=2.d0*pimach()
      arg = tpi/dfloat(ip)
      dcp = dcos(arg)
      dsp = dsin(arg)
      idp2 = ido+2
      nbd = (ido-1)/2
      ipp2 = ip+2
      ipph = (ip+1)/2
      if (ido .lt. l1) go to 103
      do 102 k=1,l1
         do 101 i=1,ido
            do 1001 m=1,mp
            ch(m,i,k,1) = cc(m,i,1,k)
 1001       continue
  101    continue
  102 continue
      go to 106
  103 do 105 i=1,ido
         do 104 k=1,l1
            do 1004 m=1,mp
            ch(m,i,k,1) = cc(m,i,1,k)
 1004       continue
  104    continue
  105 continue
  106 do 108 j=2,ipph
         jc = ipp2-j
         j2 = j+j
         do 107 k=1,l1
            do 1007 m=1,mp
            ch(m,1,k,j) = cc(m,ido,j2-2,k)+cc(m,ido,j2-2,k)
            ch(m,1,k,jc) = cc(m,1,j2-1,k)+cc(m,1,j2-1,k)
 1007       continue
  107    continue
  108 continue
      if (ido .eq. 1) go to 116
      if (nbd .lt. l1) go to 112
      do 111 j=2,ipph
         jc = ipp2-j
         do 110 k=1,l1
            do 109 i=3,ido,2
               ic = idp2-i
               do 1009 m=1,mp
               ch(m,i-1,k,j) = cc(m,i-1,2*j-1,k)+cc(m,ic-1,2*j-2,k)
               ch(m,i-1,k,jc) = cc(m,i-1,2*j-1,k)-cc(m,ic-1,2*j-2,k)
               ch(m,i,k,j) = cc(m,i,2*j-1,k)-cc(m,ic,2*j-2,k)
               ch(m,i,k,jc) = cc(m,i,2*j-1,k)+cc(m,ic,2*j-2,k)
 1009          continue
  109       continue
  110    continue
  111 continue
      go to 116
  112 do 115 j=2,ipph
         jc = ipp2-j
         do 114 i=3,ido,2
            ic = idp2-i
            do 113 k=1,l1
               do 1013 m=1,mp
               ch(m,i-1,k,j) = cc(m,i-1,2*j-1,k)+cc(m,ic-1,2*j-2,k)
               ch(m,i-1,k,jc) = cc(m,i-1,2*j-1,k)-cc(m,ic-1,2*j-2,k)
               ch(m,i,k,j) = cc(m,i,2*j-1,k)-cc(m,ic,2*j-2,k)
               ch(m,i,k,jc) = cc(m,i,2*j-1,k)+cc(m,ic,2*j-2,k)
 1013          continue
  113       continue
  114    continue
  115 continue
  116 ar1 = 1.d0
      ai1 = 0.d0
      do 120 l=2,ipph
         lc = ipp2-l
         ar1h = dcp*ar1-dsp*ai1
         ai1 = dcp*ai1+dsp*ar1
         ar1 = ar1h
         do 117 ik=1,idl1
            do 1017 m=1,mp
            c2(m,ik,l) = ch2(m,ik,1)+ar1*ch2(m,ik,2)
            c2(m,ik,lc) = ai1*ch2(m,ik,ip)
 1017       continue
  117    continue
         dc2 = ar1
         ds2 = ai1
         ar2 = ar1
         ai2 = ai1
         do 119 j=3,ipph
            jc = ipp2-j
            ar2h = dc2*ar2-ds2*ai2
            ai2 = dc2*ai2+ds2*ar2
            ar2 = ar2h
            do 118 ik=1,idl1
               do 1018 m=1,mp
               c2(m,ik,l) = c2(m,ik,l)+ar2*ch2(m,ik,j)
               c2(m,ik,lc) = c2(m,ik,lc)+ai2*ch2(m,ik,jc)
 1018          continue
  118       continue
  119    continue
  120 continue
      do 122 j=2,ipph
         do 121 ik=1,idl1
            do 1021 m=1,mp
            ch2(m,ik,1) = ch2(m,ik,1)+ch2(m,ik,j)
 1021       continue
  121    continue
  122 continue
      do 124 j=2,ipph
         jc = ipp2-j
         do 123 k=1,l1
            do 1023 m=1,mp
            ch(m,1,k,j) = c1(m,1,k,j)-c1(m,1,k,jc)
            ch(m,1,k,jc) = c1(m,1,k,j)+c1(m,1,k,jc)
 1023       continue
  123    continue
  124 continue
      if (ido .eq. 1) go to 132
      if (nbd .lt. l1) go to 128
      do 127 j=2,ipph
         jc = ipp2-j
         do 126 k=1,l1
            do 125 i=3,ido,2
               do 1025 m=1,mp
               ch(m,i-1,k,j) = c1(m,i-1,k,j)-c1(m,i,k,jc)
               ch(m,i-1,k,jc) = c1(m,i-1,k,j)+c1(m,i,k,jc)
               ch(m,i,k,j) = c1(m,i,k,j)+c1(m,i-1,k,jc)
               ch(m,i,k,jc) = c1(m,i,k,j)-c1(m,i-1,k,jc)
 1025          continue
  125       continue
  126    continue
  127 continue
      go to 132
  128 do 131 j=2,ipph
         jc = ipp2-j
         do 130 i=3,ido,2
            do 129 k=1,l1
               do 1029 m=1,mp
               ch(m,i-1,k,j) = c1(m,i-1,k,j)-c1(m,i,k,jc)
               ch(m,i-1,k,jc) = c1(m,i-1,k,j)+c1(m,i,k,jc)
               ch(m,i,k,j) = c1(m,i,k,j)+c1(m,i-1,k,jc)
               ch(m,i,k,jc) = c1(m,i,k,j)-c1(m,i-1,k,jc)
 1029          continue
  129       continue
  130    continue
  131 continue
  132 continue
      if (ido .eq. 1) return
      do 133 ik=1,idl1
         do 1033 m=1,mp
         c2(m,ik,1) = ch2(m,ik,1)
 1033    continue
  133 continue
      do 135 j=2,ip
         do 134 k=1,l1
            do 1034 m=1,mp
            c1(m,1,k,j) = ch(m,1,k,j)
 1034       continue
  134    continue
  135 continue
      if (nbd .gt. l1) go to 139
      is = -ido
      do 138 j=2,ip
         is = is+ido
         idij = is
         do 137 i=3,ido,2
            idij = idij+2
            do 136 k=1,l1
               do 1036 m=1,mp
               c1(m,i-1,k,j) = wa(idij-1)*ch(m,i-1,k,j)-wa(idij)*
     1          ch(m,i,k,j)
               c1(m,i,k,j) = wa(idij-1)*ch(m,i,k,j)+wa(idij)*
     1          ch(m,i-1,k,j)
 1036          continue
  136       continue
  137    continue
  138 continue
      go to 143
  139 is = -ido
      do 142 j=2,ip
         is = is+ido
         do 141 k=1,l1
            idij = is
            do 140 i=3,ido,2
               idij = idij+2
               do 1040 m=1,mp
               c1(m,i-1,k,j) = wa(idij-1)*ch(m,i-1,k,j)-wa(idij)*
     1          ch(m,i,k,j)
               c1(m,i,k,j) = wa(idij-1)*ch(m,i,k,j)+wa(idij)*
     1          ch(m,i-1,k,j)
 1040          continue
  140       continue
  141    continue
  142 continue
  143 return
      end
      subroutine hradb4 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1,wa2,wa3)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension  cc(mdimcc,ido,4,l1)  ,ch(mdimch,ido,l1,4)    ,
     1                wa1(ido)  ,wa2(ido)  ,wa3(ido)
      sqrt2=dsqrt(2.d0)
      do 101 k=1,l1
          do 1001 m=1,mp
         ch(m,1,k,3) = (cc(m,1,1,k)+cc(m,ido,4,k))
     1   -(cc(m,ido,2,k)+cc(m,ido,2,k))
         ch(m,1,k,1) = (cc(m,1,1,k)+cc(m,ido,4,k))
     1   +(cc(m,ido,2,k)+cc(m,ido,2,k))
         ch(m,1,k,4) = (cc(m,1,1,k)-cc(m,ido,4,k))
     1   +(cc(m,1,3,k)+cc(m,1,3,k))
         ch(m,1,k,2) = (cc(m,1,1,k)-cc(m,ido,4,k))
     1   -(cc(m,1,3,k)+cc(m,1,3,k))
 1001     continue
  101 continue
      if (ido-2) 107,105,102
  102 idp2 = ido+2
      do 104 k=1,l1
         do 103 i=3,ido,2
            ic = idp2-i
               do 1002 m=1,mp
            ch(m,i-1,k,1) = (cc(m,i-1,1,k)+cc(m,ic-1,4,k))
     1      +(cc(m,i-1,3,k)+cc(m,ic-1,2,k))
            ch(m,i,k,1) = (cc(m,i,1,k)-cc(m,ic,4,k))
     1      +(cc(m,i,3,k)-cc(m,ic,2,k))
            ch(m,i-1,k,2)=wa1(i-2)*((cc(m,i-1,1,k)-cc(m,ic-1,4,k))
     1      -(cc(m,i,3,k)+cc(m,ic,2,k)))-wa1(i-1)
     1      *((cc(m,i,1,k)+cc(m,ic,4,k))+(cc(m,i-1,3,k)-cc(m,ic-1,2,k)))
            ch(m,i,k,2)=wa1(i-2)*((cc(m,i,1,k)+cc(m,ic,4,k))
     1      +(cc(m,i-1,3,k)-cc(m,ic-1,2,k)))+wa1(i-1)
     1      *((cc(m,i-1,1,k)-cc(m,ic-1,4,k))-(cc(m,i,3,k)+cc(m,ic,2,k)))
            ch(m,i-1,k,3)=wa2(i-2)*((cc(m,i-1,1,k)+cc(m,ic-1,4,k))
     1      -(cc(m,i-1,3,k)+cc(m,ic-1,2,k)))-wa2(i-1)
     1      *((cc(m,i,1,k)-cc(m,ic,4,k))-(cc(m,i,3,k)-cc(m,ic,2,k)))
            ch(m,i,k,3)=wa2(i-2)*((cc(m,i,1,k)-cc(m,ic,4,k))
     1      -(cc(m,i,3,k)-cc(m,ic,2,k)))+wa2(i-1)
     1      *((cc(m,i-1,1,k)+cc(m,ic-1,4,k))-(cc(m,i-1,3,k)
     1      +cc(m,ic-1,2,k)))
            ch(m,i-1,k,4)=wa3(i-2)*((cc(m,i-1,1,k)-cc(m,ic-1,4,k))
     1      +(cc(m,i,3,k)+cc(m,ic,2,k)))-wa3(i-1)
     1     *((cc(m,i,1,k)+cc(m,ic,4,k))-(cc(m,i-1,3,k)-cc(m,ic-1,2,k)))
            ch(m,i,k,4)=wa3(i-2)*((cc(m,i,1,k)+cc(m,ic,4,k))
     1      -(cc(m,i-1,3,k)-cc(m,ic-1,2,k)))+wa3(i-1)
     1      *((cc(m,i-1,1,k)-cc(m,ic-1,4,k))+(cc(m,i,3,k)+cc(m,ic,2,k)))
 1002          continue
  103    continue
  104 continue
      if (mod(ido,2) .eq. 1) return
  105 continue
      do 106 k=1,l1
               do 1003 m=1,mp
         ch(m,ido,k,1) = (cc(m,ido,1,k)+cc(m,ido,3,k))
     1   +(cc(m,ido,1,k)+cc(m,ido,3,k))
         ch(m,ido,k,2) = sqrt2*((cc(m,ido,1,k)-cc(m,ido,3,k))
     1   -(cc(m,1,2,k)+cc(m,1,4,k)))
         ch(m,ido,k,3) = (cc(m,1,4,k)-cc(m,1,2,k))
     1   +(cc(m,1,4,k)-cc(m,1,2,k))
         ch(m,ido,k,4) = -sqrt2*((cc(m,ido,1,k)-cc(m,ido,3,k))
     1   +(cc(m,1,2,k)+cc(m,1,4,k)))
 1003          continue
  106 continue
  107 return
      end
      subroutine hradb2 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension  cc(mdimcc,ido,2,l1)    ,ch(mdimch,ido,l1,2),
     1                wa1(ido)
      do 101 k=1,l1
          do 1001 m=1,mp
         ch(m,1,k,1) = cc(m,1,1,k)+cc(m,ido,2,k)
         ch(m,1,k,2) = cc(m,1,1,k)-cc(m,ido,2,k)
 1001     continue
  101 continue
      if (ido-2) 107,105,102
  102 idp2 = ido+2
      do 104 k=1,l1
         do 103 i=3,ido,2
            ic = idp2-i
               do 1002 m=1,mp
            ch(m,i-1,k,1) = cc(m,i-1,1,k)+cc(m,ic-1,2,k)
            ch(m,i,k,1) = cc(m,i,1,k)-cc(m,ic,2,k)
            ch(m,i-1,k,2) = wa1(i-2)*(cc(m,i-1,1,k)-cc(m,ic-1,2,k))
     1      -wa1(i-1)*(cc(m,i,1,k)+cc(m,ic,2,k))
            ch(m,i,k,2) = wa1(i-2)*(cc(m,i,1,k)+cc(m,ic,2,k))+wa1(i-1)
     1      *(cc(m,i-1,1,k)-cc(m,ic-1,2,k))
 1002          continue
  103    continue
  104 continue
      if (mod(ido,2) .eq. 1) return
  105 do 106 k=1,l1
          do 1003 m=1,mp
         ch(m,ido,k,1) = cc(m,ido,1,k)+cc(m,ido,1,k)
         ch(m,ido,k,2) = -(cc(m,1,2,k)+cc(m,1,2,k))
 1003     continue
  106 continue
  107 return
      end
      subroutine hradb3 (mp,ido,l1,cc,mdimcc,ch,mdimch,wa1,wa2)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension  cc(mdimcc,ido,3,l1)    ,ch(mdimch,ido,l1,3),
     1                wa1(ido)   ,wa2(ido)
      arg=2.d0*pimach()/3.d0
      taur=dcos(arg)
      taui=dsin(arg)
      do 101 k=1,l1
          do 1001 m=1,mp
         ch(m,1,k,1) = cc(m,1,1,k)+2.d0*cc(m,ido,2,k)
         ch(m,1,k,2) = cc(m,1,1,k)+(2.d0*taur)*cc(m,ido,2,k)
     1   -(2.d0*taui)*cc(m,1,3,k)
         ch(m,1,k,3) = cc(m,1,1,k)+(2.d0*taur)*cc(m,ido,2,k)
     1   +2.d0*taui*cc(m,1,3,k)
 1001     continue
  101 continue
      if (ido .eq. 1) return
      idp2 = ido+2
      do 103 k=1,l1
         do 102 i=3,ido,2
            ic = idp2-i
               do 1002 m=1,mp
            ch(m,i-1,k,1) = cc(m,i-1,1,k)+(cc(m,i-1,3,k)+cc(m,ic-1,2,k))
            ch(m,i,k,1) = cc(m,i,1,k)+(cc(m,i,3,k)-cc(m,ic,2,k))
            ch(m,i-1,k,2) = wa1(i-2)*
     1 ((cc(m,i-1,1,k)+taur*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)))-
     * (taui*(cc(m,i,3,k)+cc(m,ic,2,k))))
     2                   -wa1(i-1)*
     3 ((cc(m,i,1,k)+taur*(cc(m,i,3,k)-cc(m,ic,2,k)))+
     * (taui*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))))
            ch(m,i,k,2) = wa1(i-2)*
     4 ((cc(m,i,1,k)+taur*(cc(m,i,3,k)-cc(m,ic,2,k)))+
     8 (taui*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))))
     5                  +wa1(i-1)*
     6 ((cc(m,i-1,1,k)+taur*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)))-
     8 (taui*(cc(m,i,3,k)+cc(m,ic,2,k))))
              ch(m,i-1,k,3) = wa2(i-2)*
     7 ((cc(m,i-1,1,k)+taur*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)))+
     8 (taui*(cc(m,i,3,k)+cc(m,ic,2,k))))
     8   -wa2(i-1)*
     9 ((cc(m,i,1,k)+taur*(cc(m,i,3,k)-cc(m,ic,2,k)))-
     8 (taui*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))))
            ch(m,i,k,3) = wa2(i-2)*
     1 ((cc(m,i,1,k)+taur*(cc(m,i,3,k)-cc(m,ic,2,k)))-
     8 (taui*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))))
     2                 +wa2(i-1)*
     3 ((cc(m,i-1,1,k)+taur*(cc(m,i-1,3,k)+cc(m,ic-1,2,k)))+
     8 (taui*(cc(m,i,3,k)+cc(m,ic,2,k))))
 1002          continue
  102    continue
  103 continue
      return
      end
      subroutine hradb5 (mp,ido,l1,cc,mdimcc,ch,mdimch,
     1       wa1,wa2,wa3,wa4)
      implicit double precision (a-h,o-z)
c
c     a multiple fft package for spherepack
c
      dimension  cc(mdimcc,ido,5,l1)    ,ch(mdimch,ido,l1,5),
     1             wa1(ido)     ,wa2(ido)     ,wa3(ido)     ,wa4(ido)
      arg=2.d0*pimach()/5.d0
      tr11=dcos(arg)
      ti11=dsin(arg)
      tr12=dcos(2.d0*arg)
      ti12=dsin(2.d0*arg)
      do 101 k=1,l1
      do 1001 m=1,mp
         ch(m,1,k,1) = cc(m,1,1,k)+2.d0*cc(m,ido,2,k)+2.d0*cc(m,ido,4,k)
         ch(m,1,k,2) = (cc(m,1,1,k)+tr11*2.d0*cc(m,ido,2,k)
     1   +tr12*2.d0*cc(m,ido,4,k))-(ti11*2.d0*cc(m,1,3,k)
     1   +ti12*2.d0*cc(m,1,5,k))
         ch(m,1,k,3) = (cc(m,1,1,k)+tr12*2.d0*cc(m,ido,2,k)
     1   +tr11*2.d0*cc(m,ido,4,k))-(ti12*2.d0*cc(m,1,3,k)
     1   -ti11*2.d0*cc(m,1,5,k))
         ch(m,1,k,4) = (cc(m,1,1,k)+tr12*2.d0*cc(m,ido,2,k)
     1   +tr11*2.d0*cc(m,ido,4,k))+(ti12*2.d0*cc(m,1,3,k)
     1   -ti11*2.d0*cc(m,1,5,k))
         ch(m,1,k,5) = (cc(m,1,1,k)+tr11*2.d0*cc(m,ido,2,k)
     1   +tr12*2.d0*cc(m,ido,4,k))+(ti11*2.d0*cc(m,1,3,k)
     1   +ti12*2.d0*cc(m,1,5,k))
 1001          continue
  101 continue
      if (ido .eq. 1) return
      idp2 = ido+2
      do 103 k=1,l1
         do 102 i=3,ido,2
            ic = idp2-i
      do 1002 m=1,mp
            ch(m,i-1,k,1) = cc(m,i-1,1,k)+(cc(m,i-1,3,k)+cc(m,ic-1,2,k))
     1      +(cc(m,i-1,5,k)+cc(m,ic-1,4,k))
            ch(m,i,k,1) = cc(m,i,1,k)+(cc(m,i,3,k)-cc(m,ic,2,k))
     1      +(cc(m,i,5,k)-cc(m,ic,4,k))
            ch(m,i-1,k,2) = wa1(i-2)*((cc(m,i-1,1,k)+tr11*
     1      (cc(m,i-1,3,k)+cc(m,ic-1,2,k))+tr12
     1      *(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))-(ti11*(cc(m,i,3,k)
     1      +cc(m,ic,2,k))+ti12*(cc(m,i,5,k)+cc(m,ic,4,k))))
     1      -wa1(i-1)*((cc(m,i,1,k)+tr11*(cc(m,i,3,k)-cc(m,ic,2,k))
     1      +tr12*(cc(m,i,5,k)-cc(m,ic,4,k)))+(ti11*(cc(m,i-1,3,k)
     1      -cc(m,ic-1,2,k))+ti12*(cc(m,i-1,5,k)-cc(m,ic-1,4,k))))
            ch(m,i,k,2) = wa1(i-2)*((cc(m,i,1,k)+tr11*(cc(m,i,3,k)
     1      -cc(m,ic,2,k))+tr12*(cc(m,i,5,k)-cc(m,ic,4,k)))
     1      +(ti11*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))+ti12
     1      *(cc(m,i-1,5,k)-cc(m,ic-1,4,k))))+wa1(i-1)
     1      *((cc(m,i-1,1,k)+tr11*(cc(m,i-1,3,k)
     1      +cc(m,ic-1,2,k))+tr12*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))
     1      -(ti11*(cc(m,i,3,k)+cc(m,ic,2,k))+ti12
     1      *(cc(m,i,5,k)+cc(m,ic,4,k))))
            ch(m,i-1,k,3) = wa2(i-2)
     1      *((cc(m,i-1,1,k)+tr12*(cc(m,i-1,3,k)+cc(m,ic-1,2,k))
     1      +tr11*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))-(ti12*(cc(m,i,3,k)
     1      +cc(m,ic,2,k))-ti11*(cc(m,i,5,k)+cc(m,ic,4,k))))
     1     -wa2(i-1)
     1     *((cc(m,i,1,k)+tr12*(cc(m,i,3,k)-
     1      cc(m,ic,2,k))+tr11*(cc(m,i,5,k)-cc(m,ic,4,k)))
     1      +(ti12*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))-ti11
     1      *(cc(m,i-1,5,k)-cc(m,ic-1,4,k))))
            ch(m,i,k,3) = wa2(i-2)
     1     *((cc(m,i,1,k)+tr12*(cc(m,i,3,k)-
     1      cc(m,ic,2,k))+tr11*(cc(m,i,5,k)-cc(m,ic,4,k)))
     1      +(ti12*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))-ti11
     1      *(cc(m,i-1,5,k)-cc(m,ic-1,4,k))))
     1      +wa2(i-1)
     1      *((cc(m,i-1,1,k)+tr12*(cc(m,i-1,3,k)+cc(m,ic-1,2,k))
     1      +tr11*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))-(ti12*(cc(m,i,3,k)
     1      +cc(m,ic,2,k))-ti11*(cc(m,i,5,k)+cc(m,ic,4,k))))
            ch(m,i-1,k,4) = wa3(i-2)
     1      *((cc(m,i-1,1,k)+tr12*(cc(m,i-1,3,k)+cc(m,ic-1,2,k))
     1      +tr11*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))+(ti12*(cc(m,i,3,k)
     1      +cc(m,ic,2,k))-ti11*(cc(m,i,5,k)+cc(m,ic,4,k))))
     1      -wa3(i-1)
     1     *((cc(m,i,1,k)+tr12*(cc(m,i,3,k)-
     1      cc(m,ic,2,k))+tr11*(cc(m,i,5,k)-cc(m,ic,4,k)))
     1      -(ti12*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))-ti11
     1      *(cc(m,i-1,5,k)-cc(m,ic-1,4,k))))
            ch(m,i,k,4) = wa3(i-2)
     1     *((cc(m,i,1,k)+tr12*(cc(m,i,3,k)-
     1      cc(m,ic,2,k))+tr11*(cc(m,i,5,k)-cc(m,ic,4,k)))
     1      -(ti12*(cc(m,i-1,3,k)-cc(m,ic-1,2,k))-ti11
     1      *(cc(m,i-1,5,k)-cc(m,ic-1,4,k))))
     1      +wa3(i-1)
     1      *((cc(m,i-1,1,k)+tr12*(cc(m,i-1,3,k)+cc(m,ic-1,2,k))
     1      +tr11*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))+(ti12*(cc(m,i,3,k)
     1      +cc(m,ic,2,k))-ti11*(cc(m,i,5,k)+cc(m,ic,4,k))))
            ch(m,i-1,k,5) = wa4(i-2)
     1      *((cc(m,i-1,1,k)+tr11*(cc(m,i-1,3,k)+cc(m,ic-1,2,k))
     1      +tr12*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))+(ti11*(cc(m,i,3,k)
     1      +cc(m,ic,2,k))+ti12*(cc(m,i,5,k)+cc(m,ic,4,k))))
     1      -wa4(i-1)
     1      *((cc(m,i,1,k)+tr11*(cc(m,i,3,k)-cc(m,ic,2,k))
     1      +tr12*(cc(m,i,5,k)-cc(m,ic,4,k)))-(ti11*(cc(m,i-1,3,k)
     1      -cc(m,ic-1,2,k))+ti12*(cc(m,i-1,5,k)-cc(m,ic-1,4,k))))
            ch(m,i,k,5) = wa4(i-2)
     1      *((cc(m,i,1,k)+tr11*(cc(m,i,3,k)-cc(m,ic,2,k))
     1      +tr12*(cc(m,i,5,k)-cc(m,ic,4,k)))-(ti11*(cc(m,i-1,3,k)
     1      -cc(m,ic-1,2,k))+ti12*(cc(m,i-1,5,k)-cc(m,ic-1,4,k))))
     1      +wa4(i-1)
     1      *((cc(m,i-1,1,k)+tr11*(cc(m,i-1,3,k)+cc(m,ic-1,2,k))
     1      +tr12*(cc(m,i-1,5,k)+cc(m,ic-1,4,k)))+(ti11*(cc(m,i,3,k)
     1      +cc(m,ic,2,k))+ti12*(cc(m,i,5,k)+cc(m,ic,4,k))))
 1002          continue
  102    continue
  103 continue
      return
      end


*> \brief \b CHPTRD
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CHPTRD + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CHPTRD( UPLO, N, AP, D, E, TAU, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            INFO, N
*       ..
*       .. Array Arguments ..
*       REAL               D( * ), E( * )
*       COMPLEX            AP( * ), TAU( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CHPTRD reduces a complex Hermitian matrix A stored in packed form to
*> real symmetric tridiagonal form T by a unitary similarity
*> transformation: Q**H * A * Q = T.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  Upper triangle of A is stored;
*>          = 'L':  Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*>          AP is COMPLEX array, dimension (N*(N+1)/2)
*>          On entry, the upper or lower triangle of the Hermitian matrix
*>          A, packed columnwise in a linear array.  The j-th column of A
*>          is stored in the array AP as follows:
*>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*>          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
*>          On exit, if UPLO = 'U', the diagonal and first superdiagonal
*>          of A are overwritten by the corresponding elements of the
*>          tridiagonal matrix T, and the elements above the first
*>          superdiagonal, with the array TAU, represent the unitary
*>          matrix Q as a product of elementary reflectors; if UPLO
*>          = 'L', the diagonal and first subdiagonal of A are over-
*>          written by the corresponding elements of the tridiagonal
*>          matrix T, and the elements below the first subdiagonal, with
*>          the array TAU, represent the unitary matrix Q as a product
*>          of elementary reflectors. See Further Details.
*> \endverbatim
*>
*> \param[out] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          The diagonal elements of the tridiagonal matrix T:
*>          D(i) = A(i,i).
*> \endverbatim
*>
*> \param[out] E
*> \verbatim
*>          E is REAL array, dimension (N-1)
*>          The off-diagonal elements of the tridiagonal matrix T:
*>          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*>          TAU is COMPLEX array, dimension (N-1)
*>          The scalar factors of the elementary reflectors (see Further
*>          Details).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexOTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  If UPLO = 'U', the matrix Q is represented as a product of elementary
*>  reflectors
*>
*>     Q = H(n-1) . . . H(2) H(1).
*>
*>  Each H(i) has the form
*>
*>     H(i) = I - tau * v * v**H
*>
*>  where tau is a complex scalar, and v is a complex vector with
*>  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
*>  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
*>
*>  If UPLO = 'L', the matrix Q is represented as a product of elementary
*>  reflectors
*>
*>     Q = H(1) H(2) . . . H(n-1).
*>
*>  Each H(i) has the form
*>
*>     H(i) = I - tau * v * v**H
*>
*>  where tau is a complex scalar, and v is a complex vector with
*>  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
*>  overwriting A(i+2:n,i), and tau is stored in TAU(i).
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE CHPTRD( UPLO, N, AP, D, E, TAU, INFO )
*
*  -- LAPACK computational routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * )
      COMPLEX            AP( * ), TAU( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            ONE, ZERO, HALF
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
     $                   ZERO = ( 0.0E+0, 0.0E+0 ),
     $                   HALF = ( 0.5E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, I1, I1I1, II
      COMPLEX            ALPHA, TAUI
*     ..
*     .. External Subroutines ..
      EXTERNAL           CAXPY, CHPMV, CHPR2, CLARFG, XERBLA
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      COMPLEX            CDOTC
      EXTERNAL           LSAME, CDOTC
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          REAL
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CHPTRD', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.LE.0 )
     $   RETURN
*
      IF( UPPER ) THEN
*
*        Reduce the upper triangle of A.
*        I1 is the index in AP of A(1,I+1).
*
         I1 = N*( N-1 ) / 2 + 1
         AP( I1+N-1 ) = REAL( AP( I1+N-1 ) )
         DO 10 I = N - 1, 1, -1
*
*           Generate elementary reflector H(i) = I - tau * v * v**H
*           to annihilate A(1:i-1,i+1)
*
            ALPHA = AP( I1+I-1 )
            CALL CLARFG( I, ALPHA, AP( I1 ), 1, TAUI )
            E( I ) = ALPHA
*
            IF( TAUI.NE.ZERO ) THEN
*
*              Apply H(i) from both sides to A(1:i,1:i)
*
               AP( I1+I-1 ) = ONE
*
*              Compute  y := tau * A * v  storing y in TAU(1:i)
*
               CALL CHPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
     $                     1 )
*
*              Compute  w := y - 1/2 * tau * (y**H *v) * v
*
               ALPHA = -HALF*TAUI*CDOTC( I, TAU, 1, AP( I1 ), 1 )
               CALL CAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
*
*              Apply the transformation as a rank-2 update:
*                 A := A - v * w**H - w * v**H
*
               CALL CHPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
*
            END IF
            AP( I1+I-1 ) = E( I )
            D( I+1 ) = AP( I1+I )
            TAU( I ) = TAUI
            I1 = I1 - I
   10    CONTINUE
         D( 1 ) = AP( 1 )
      ELSE
*
*        Reduce the lower triangle of A. II is the index in AP of
*        A(i,i) and I1I1 is the index of A(i+1,i+1).
*
         II = 1
         AP( 1 ) = REAL( AP( 1 ) )
         DO 20 I = 1, N - 1
            I1I1 = II + N - I + 1
*
*           Generate elementary reflector H(i) = I - tau * v * v**H
*           to annihilate A(i+2:n,i)
*
            ALPHA = AP( II+1 )
            CALL CLARFG( N-I, ALPHA, AP( II+2 ), 1, TAUI )
            E( I ) = ALPHA
*
            IF( TAUI.NE.ZERO ) THEN
*
*              Apply H(i) from both sides to A(i+1:n,i+1:n)
*
               AP( II+1 ) = ONE
*
*              Compute  y := tau * A * v  storing y in TAU(i:n-1)
*
               CALL CHPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
     $                     ZERO, TAU( I ), 1 )
*
*              Compute  w := y - 1/2 * tau * (y**H *v) * v
*
               ALPHA = -HALF*TAUI*CDOTC( N-I, TAU( I ), 1, AP( II+1 ),
     $                 1 )
               CALL CAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
*
*              Apply the transformation as a rank-2 update:
*                 A := A - v * w**H - w * v**H
*
               CALL CHPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
     $                     AP( I1I1 ) )
*
            END IF
            AP( II+1 ) = E( I )
            D( I ) = AP( II )
            TAU( I ) = TAUI
            II = I1I1
   20    CONTINUE
         D( N ) = AP( II )
      END IF
*
      RETURN
*
*     End of CHPTRD
*
      END


      subroutine imppow(ndata,x,y,a)
c
c     + + + PURPOSE + + +
c
c     SR IMPPOW is an impoundment element subroutine used to
c     develop power function fit coefficients.  It is based
c     upon the "Numerical Recipes in Fortran" SR SVDFIT.
c
c     Called from: IMPINT
c
c     Copyright (C) 1986, 1992 Numerical Recipes Software
c
c     Permission is granted for use only within USDA Water Erosion
c     Prediction Project code
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      integer ndata
      real x(100), y(100), a(5)
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     a(i)  - the fit coefficients returned to SR IMPINT
c     ndata - number of points to be fitted
c     x(i)  - stage values from SR IMPINT
c     y(i)  - discharge values from SR IMPINT
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
      integer ma, mp, np, i, j
      real chisq, u(100,5), v(5,5), w(5), tol, sum, thresh, wmax,
     1    afunc(5), b(100)
c
c     + + + LOCAL DEFINITIONS + + +
c
c     Variable definitions (note:  this is a canned subroutine
c     only the varibles entering and exiting are defined)
c
c     afunc(i) - the transformed x values
c     ma       - number of x values in the function (2)
c     mp       - number of pairs of points included in the regression
c     np       - set to ma
c     u(i,j)   - transformed matrix of x values
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     impsvb
c     impsvd
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      ma = 2
      mp = ndata
      np = ma
      tol = 1.e-5
c
c     defining afunc and u
c
      do 20 i = 1, ndata
        afunc(1) = 1.
        afunc(2) = log10(x(i))
        y(i) = log10(y(i))
c
        do 10 j = 1, ma
          u(i,j) = afunc(j)
   10   continue
c
        b(i) = y(i)
   20 continue
c
      call impsvd(u,ndata,ma,w,v)
c
      wmax = 0.0
c
      do 30 j = 1, ma
        if (w(j).gt.wmax) wmax = w(j)
   30 continue
c
      thresh = tol * wmax
c
      do 40 j = 1, ma
        if (w(j).lt.thresh) w(j) = 0.
   40 continue
c
      call impsvb(u,w,v,ndata,ma,b,a)
c
      chisq = 0.0
c
      do 60 i = 1, ndata
        afunc(1) = 1.
        afunc(2) = log10(x(i))
        sum = 0.0
c
        do 50 j = 1, ma
          sum = sum + a(j) * afunc(j)
   50   continue
c
        chisq = chisq + (y(i)-sum) ** 2
        y(i) = 10.0 ** (y(i))
c
   60 continue
c
      return
      end


module modContinuity

    use modValues
    implicit none

    contains

    !========= Pressure Equations ============
    subroutine getContinuity(solMethod)
        implicit none

        character(len=*) :: solMethod

        if( trim(solMethod) == 'explicit' ) then
            CALL getRho_explicit
            !stop
        elseif( trim(solMethod) == 'implicit' ) then
            CALL getRho_implicit
        endif

    endsubroutine

    !========================================================

    subroutine getRho_implicit
        use modFaceValues
        implicit none

        CALL getFaceValues(&
            FaceMethodU=chFluxU &
            )

        !> Update to Density
        do i=nCellStr,nCellEnd
            lFace = i-1; rFace = i

            AmatCon(i,i) = 1.d0/timestep &
                - fgN(lFace)*fU(lFace)*area(lFace)/cVol(i) &
                + fgP(rFace)*fU(rFace)*area(rFace)/cVol(i)
            if( i/=nCellStr ) then
                AmatCon(i,i-1) = &
                    - fgP(lFace)*fU(lFace)*area(lFace)/cVol(i)
            endif
            if( i/=nCellEnd ) then
                AmatCon(i,i+1) = &
                    + fgN(rFace)*fU(rFace)*area(rFace)/cVol(i)
            endif

            BmatCon(i) = &
                -( cRho(i) - oldCons(i,1) )/timestep &
                +1.d0/cVol(i)*( fMdot(lFace) - fMdot(rFace) )
        enddo
        !> inverse of A matrix
        CALL matInverse(AmatCon,nCellEnd)

        !> dR update
        cDR(nCellStr:nCellEnd) = &
            underRelaxFactR &
            *matmul(AmatCon(nCellStr:nCellEnd,nCellStr:nCellEnd),&
                    BmatCon(nCellStr:nCellEnd))

        !> Rho update
        cRho(nCellStr:nCellEnd) = cRho(nCellStr:nCellEnd) + cDR(nCellStr:nCellEnd)

    endsubroutine

    !========================================================
    subroutine getRho_explicit
        use modFaceValues
        implicit none

        CALL getFaceValues(&
            FaceMethodU=chFluxU &
            )

        !> Update to Density
        do i=nCellStr,nCellEnd
            lFace = i-1; rFace = i

            cDR(i) = &
                - (cRho(i)-oldcRho(i)) &
                + timestep/cVol(i)*( fMdot(lFace) - fMdot(rFace) )
            cRho(i) = cRho(i) + underRelaxFactR*cDR(i)
        enddo

    endsubroutine

endmodule


      subroutine irev_dlamx(ctfm,ctfmp,n_A,n_Athth,n_Axx,n_B,n_K,n_Lamx,
     &n_Sx,n_alpha,n_beta,n_divbeta,n_phi,nm1_Lamx,np1_Lamx,octfmp,Nx,ht
     &,hx,vee,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 vee
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_Athth(Nx)
      real*8 n_Axx(Nx)
      real*8 n_B(Nx)
      real*8 n_K(Nx)
      real*8 n_Lamx(Nx)
      real*8 n_Sx(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_divbeta(Nx)
      real*8 n_phi(Nx)
      real*8 nm1_Lamx(Nx)
      real*8 np1_Lamx(Nx)
      real*8 octfmp(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=2, Nx-1, 1
      qb = 0.5000000000000000D0 * (-0.1D1 * nm1_Lamx(i) + np1_Lamx(i)) /
     # ht - 0.6666666666666667D0 * n_divbeta(i) * n_Lamx(i) * vee + 0.2D
     #1 / n_A(i) * n_alpha(i) * n_Sx(i) - 0.1D1 * (0.5000000000000000D0
     #/ n_A(i) ** 3 * n_Axx(i) * n_alpha(i) * (-0.1D1 * n_A(i - 1) + n_A
     #(i + 1)) / hx + 0.1D1 / n_B(i) ** 2 / n_A(i) * (n_B(i - 1) - 0.1D1
     # * n_B(i + 1)) / hx * n_Athth(i) * n_alpha(i) - 0.6666666666666667
     #D0 / n_A(i) * n_alpha(i) * (-0.1D1 * n_K(i - 1) + n_K(i + 1)) / hx
     # - 0.5000000000000000D0 * n_beta(i) * (n_Lamx(i - 1) - 0.1D1 * n_L
     #amx(i + 1)) / hx - 0.1D1 / n_A(i) ** 2 * n_Axx(i) * (-0.1D1 * n_al
     #pha(i - 1) + n_alpha(i + 1)) / hx + 0.5000000000000000D0 * n_Lamx(
     #i) * (n_beta(i - 1) - 0.1D1 * n_beta(i + 1)) / hx + 0.500000000000
     #0000D0 * (n_beta(i - 1) - 0.1D1 * n_beta(i + 1)) / hx / n_A(i) * o
     #ctfmp(i) + 0.1666666666666667D0 / n_A(i) * vee * (-0.1D1 * n_divbe
     #ta(i - 1) + n_divbeta(i + 1)) / hx - 0.6D1 / n_A(i) ** 2 * n_alpha
     #(i) * n_Axx(i) * (n_phi(i - 1) - 0.1D1 * n_phi(i + 1)) / hx) / ctf
     #mp(i) + 0.1D1 / n_A(i) / ctfmp(i) ** 2 * (-0.1D1 * n_beta(i - 1) +
     # 0.2D1 * n_beta(i) - 0.1D1 * n_beta(i + 1)) / hx ** 2 - 0.1D1 * (-
     #0.4D1 / n_B(i) / n_A(i) * n_Athth(i) * n_alpha(i) + 0.4D1 / n_B(i)
     # ** 2 * n_alpha(i) * n_Athth(i) - 0.1D1 / n_B(i) * (n_beta(i - 1)
     #- 0.1D1 * n_beta(i + 1)) / hx / ctfmp(i)) / ctfm(i) + 0.2D1 / ctfm
     #(i) ** 2 / n_B(i) * n_beta(i)
      res(i)=qb
      end do
      END


      SUBROUTINE RANMAR(RVEC,LEN)
c modlib.f (ccp4 cvs 2010-05-25, but has been stable for a long time)
C     ===========================
C
C     Universal random number generator proposed by Marsaglia and Zaman
C     in report FSU-SCRI-87-50
C     slightly modified by F. James, 1988 to generate a vector
C     of pseudorandom numbers RVEC of length LEN
C     and making the COMMON block include everything needed to
C     specify completely the state of the generator.
C     Transcribed from CERN report DD/88/22.
C     Rather inelegant messing about added by D. Love, Jan. 1989 to
C     make sure initialisation always occurs.
C     *** James says that this is the preferred generator.
C     Gives bit-identical results on all machines with at least
C     24-bit mantissas in the flotaing point representation (i.e.
C     all common 32-bit computers. Fairly fast, satisfies very
C     stringent tests, has very long period and makes it very
C     simple to generate independly disjoint sequences.
C     See also RANECU.
C     The state of the generator may be saved/restored using the
C     whole contents of /RASET1/.
C     Call RANMAR to get a vector, RMARIN to initialise.
C
C  Argument list
C  -------------
C
C     VREC (O)                 (REAL)   Random Vector
C
C     LEN  (I)              (INTEGER)   Length of random vector
C
C
C  For ENTRY point RMARIN
C  ----------------------
C
C     Initialisation for RANMAR.  The input values should
C     be in the ranges: 0<=ij<=31328, 0<=kl<=30081
C     This shows the correspondence between the simplified input seeds
C     IJ, KL and the original Marsaglia-Zaman seeds i,j,k,l
C     To get standard values in Marsaglia-Zaman paper,
C     (I=12, J=34, K=56, L=78) put IJ=1802, KL=9373
C
C     IJ   (I)              (INTEGER)   Seed for random number generator
C
C     KL   (I)              (INTEGER)   Seed for randon number generator
C
C_END_RANMAR
C
C     ..
C     .. Agruments ..
      REAL RVEC(*)
      INTEGER LEN,IJ,KL
C     ..
C     .. Common Variables ..
      REAL C,CD,CM,U
      INTEGER I97,J97
C     ..
C     .. Local Scalars ..
      REAL S,T,UNI
      INTEGER I,II,IVEC,J,JJ,K,L,M
      LOGICAL INITED
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC MOD
C     ..
C     .. Common Blocks ..
      COMMON /RASET1/ U(97),C,CD,CM,I97,J97
C     ..
C     .. Save Statement ..
      SAVE INITED, /RASET1/
C     ..
C     .. Data Statement ..
      DATA INITED /.FALSE./
C
C---- If initialised, fill RVEC and RETURN. If not, do initialisation
C     and return here later.
C
 1    IF (INITED) THEN
        DO 100 IVEC=1,LEN
          UNI=U(I97)-U(J97)
          IF (UNI.LT.0.) UNI=UNI+1.
          U(I97)=UNI
          I97=I97-1
          IF (I97.EQ.0) I97=97
          J97=J97-1
          IF (J97.EQ.0) J97=97
          C=C-CD
          IF (C.LT.0.) C=C+CM
          UNI=UNI-C
          IF (UNI.LT.0.) UNI=UNI+1.
          RVEC(IVEC)=UNI
 100    CONTINUE
        RETURN
      ENDIF
      I=MOD(1802/177,177)+2
      J=MOD(1802,177)+2
      K=MOD(9373/169,178)+1
      L=MOD(9373,169)
C
      GOTO 10
C
C---- Initialise and return without filling RVEC
C
      ENTRY RMARIN(IJ,KL)
      I=MOD(IJ/177,177)+2
      J=MOD(IJ,177)+2
      K=MOD(KL/169,178)+1
      L=MOD(KL,169)
      INITED=.TRUE.

 10   CONTINUE
      DO 2 II=1,97
        S=0.
        T=.5
        DO 3 JJ=1,24
          M=MOD(MOD(I*J,179)*K,179)
          I=J
          J=K
          K=M
          L=MOD(53*L+1,169)
          IF (MOD(L*M,64).GE.32) S=S+T
          T=0.5*T
 3      CONTINUE
        U(II)=S
 2    CONTINUE
      C=362436./16777216.
      CD=7654321./16777216.
      CM=16777213./16777216.
      I97=97
      J97=33
      IF (.NOT. INITED) THEN
        INITED=.TRUE.
        GOTO 1
      ENDIF

      END


!     ------------------------------------------------------------------
Subroutine NodalForce(AE, BE, MaxLRows, XLL, NDim, iDofT, NodELT, Sol0, &
						Sol1, CommonPar, Param, JParam, DelT, DTm, Time)
!     ------------------------------------------------------------------
	use funcAux
	use loadingLib
	use finiteStrainLib
	use ptsGaussLib

	IMPLICIT NONE

	!   ===== SUBROUTINE ARGUMENTS  =======
	integer :: MaxLRows,Ndim,iDofT,NodELT ! all integers
	Real*8 :: DelT, DTm,Time ! all reals
	! Reals Vectors and matrices
	Real*8  :: AE(MaxLRows,MaxLRows), BE(MaxLRows), XLL(*), Sol0(*), Sol1(*), &
		Param(*), JParam(*), CommonPar(*)

	!   =====   END ARGUMENTS  =======

	Integer :: iShiftU, loadType
	Real*8 :: force, theta

	iShiftU = nint(CommonPar(1))
	theta = CommonPar(2)
	loadType = nint(CommonPar(3))

	theta = theta*PI
	call chooseLoad(loadType)
	call pressureLoad(force,Time,DelT,CommonPar(4:9))

	BE(iShiftU + 1) = force*dcos(theta) !! in x
	BE(iShiftU + 2) = force*dsin(theta) !! in y

end subroutine

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine NodalForceS(Coupling,CommonPar,iDofT,Ndim,MaxLRows,iAdd)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	IMPLICIT NONE
	Integer :: MaxLRows,Ndim,iDofT, iAdd
	Integer   Coupling(MaxLRows,MaxLRows)
	Real*8 CommonPar(*)

	integer :: iShiftU

	iShiftU = nint(CommonPar(1))

	Coupling(iShiftU + 1, iShiftU + 1) = 1
	Coupling(iShiftU + 2, iShiftU + 2) = 1

end Subroutine


Function fnkick(x)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Save
  fnkick = 1.0/(x+hipr1(19)**2)/(x+hipr1(20)**2)/(1+exp((sqrt(x)-hipr1(20))/0.4))
  Return
End Function fnkick


      subroutine besjh (x, lbmax, jl, hl)

c-----------------------------------------------------------------------
c
c     purpose:  to calculate the spherical bessel functions jl and hl
c               for l = 0 to lbmax (no offset)
c
c     arguments:
c       x = argument of jl and nl
c       lbmax
c       jl = jl bessel function (abramowitz conventions)
c       hl = hl^+ bessel function (messiah conventions) for Im x >=0
c       hl = hl^- bessel function (messiah conventions) for Im x < 0
c       jl and hl must be dimensioned
c            complex*16 jl(0:lbmax), hl(0:lbmax),
c
c     notes:  jl and hl should be calculated at least to 10 place
c             accuracy for the range 0<x<100 according to spot
c             checks with tables
c
c     error messages written with PRINT statement.
c
c     first coded by r. c. albers on 14 dec 82
c
c     version 3
c
c     last modified: 27 jan 83 by r. c. albers
c     dimension of jl,nl changed from 31 to 26  (10 aug 89) j. rehr
c     modified again, siz, June 1992
c     rewritten for jl and hl by a.l. ankudinov feb 2000
c
c-----------------------------------------------------------------------

      implicit double precision (a-h, o-z)
      include '../HEADERS/dim.h'

      complex*16 x
      complex*16 jl(0:lbmax), nl(ltot+2)
      complex*16 hl(0:lbmax)
      complex*16 cjl(ltot+2), sjl(ltot+2)

      complex*16 xjl,xnl,asx,acx, epx
      complex*16 xi,xi2,xi3,xi4,xi5,xi6,xi7,xi8,xi9,xi10,xi11

      parameter (xcut = 1.d0, xcut1 = 7.51d0, xcut2 = 5.01d0)
      complex*16 coni
      parameter (coni=(0.d0, 1.d0))

      if (dble(x) .lt. 0)  stop 'Re(x) is .lt. zero in besjh'

      lmax = min(lbmax, ltot+1)
      lmaxp1 = lmax + 1

      if (dble(x) .lt. xcut .and. abs(dimag(x)) .lt. xcut)  then
c        case Re(x) < 1, just use series expansion
         do 10 ll = 0,lmax
            ifl = 0
            call bjnser (x,ll,xjl,xnl,ifl)
            jl(ll) = xjl
            hl(ll) = -xnl + coni*xjl
   10    continue

      elseif (dble(x) .lt. xcut1 .and. abs(dimag(x)) .lt. xcut1)  then

c        case 1 <= Re(x) < 7.5

         call bjnser (x,lmax,xjl,xnl,1)
         jl(lmax) = xjl

         call bjnser (x,lmax-1,xjl,xnl,1)
         jl(lmax-1) = xjl

         if (dble(x) .lt. xcut2 .and. abs(dimag(x)) .lt. xcut2)  then
c           Re(x) < 5
            call bjnser (x,0,xjl,xnl,2)
            nl(1) = xnl
            call bjnser (x,1,xjl,xnl,2)
            nl(2) = xnl
         else
c           Re(x) >= 5
            asx = sin(x)
            acx = cos(x)
            xi = 1 / x
            xi2 = xi**2
            nl(1) = -acx*xi
            nl(2) = -acx*xi2 - asx*xi
         endif

c        Use recursion relation 10.1.19 to get nl and jl
         do 50 lp1 = 3, lmaxp1
            l = lp1 - 2
            tlxp1 = 2*l + 1
            nl(lp1) = tlxp1 * nl(lp1-1) / x  -  nl(lp1-2)
   50    continue

         do 60 lxx = 3,lmaxp1
            lp1 = lmaxp1+1-lxx
            l = lp1-1
            tlxp3 = 2*l + 3
            jl(l) = tlxp3 * jl(l+1) / x  -  jl(l+2)
   60    continue

         do 65 il = 1, lmaxp1
            l = il - 1
            hl(l) = -nl(il) + coni*jl(l)
   65    continue

      else
c        case Re(x) > 7.5
c        Use AS 10.1.8 and 10.1.9, sjl=P, qjl=Q, note that AS formulae
c        use cos (z - n*pi/2), etc., so cos and sin terms get a bit
c        scrambled (mod 4) here, since n is integer.  These are hard-
c        coded into the terms below.
         xi = 1 / x
         xi2  = xi*xi
         xi3  = xi*xi2
         xi4  = xi*xi3
         xi5  = xi*xi4
         xi6  = xi*xi5
         xi7  = xi*xi6
         xi8  = xi*xi7
         xi9  = xi*xi8
         xi10 = xi*xi9
         xi11 = xi*xi10

         sjl(1) = xi
         sjl(2) = xi2
         sjl(3) = 3*xi3 - xi
         sjl(4) = 15*xi4 - 6*xi2
         sjl(5) = 105*xi5 - 45*xi3 + xi
         sjl(6) = 945*xi6 - 420*xi4 + 15*xi2
         sjl(7) = 10395*xi7 - 4725*xi5 + 210*xi3 - xi
         sjl(8) = 135135*xi8 - 62370*xi6 + 3150*xi4 - 28*xi2
         sjl(9) = 2027025*xi9 - 945945*xi7 + 51975*xi5
     1            - 630*xi3 + xi
         sjl(10) = 34459425*xi10 - 16216200*xi8 + 945945*xi6
     1            - 13860*xi4 + 45*xi2
         sjl(11) = 654729075*xi11 - 310134825*xi9 + 18918900*xi7
     1            - 315315*xi5 + 1485*xi3 - xi
         cjl(1) = 0
         cjl(2) = -xi
         cjl(3) = -3*xi2
         cjl(4) = -15*xi3 + xi
         cjl(5) = -105*xi4 + 10*xi2
         cjl(6) = -945*xi5 + 105*xi3 - xi
         cjl(7) = -10395*xi6 + 1260*xi4 - 21*xi2
         cjl(8) = -135135*xi7 + 17325*xi5 - 378*xi3 + xi
         cjl(9) = -2027025*xi8 + 270270*xi6 - 6930*xi4 + 36*xi2
         cjl(10) = -34459425*xi9 + 4729725*xi7 - 135135*xi5
     1             + 990*xi3 - xi
         cjl(11) = -654729075*xi10 + 91891800*xi8 - 2837835*xi6
     1             + 25740*xi4 - 55*xi2
         do 90 lp1 = 12,lmaxp1
            l = lp1-2
            tlxp1 = float(2*l+1)
            sjl(lp1) = tlxp1*xi*sjl(lp1-1)-sjl(lp1-2)
            cjl(lp1) = tlxp1*xi*cjl(lp1-1)-cjl(lp1-2)
   90    continue
         asx = sin(x)
         acx = cos(x)
         if (dimag(x).ge. 0.d0) then
           epx = exp(coni*x)
         else
           epx = exp(-coni*x)
         endif
         do 110 ll = 0,lmax
            lp1 = ll + 1
            jl(ll) = asx*sjl(lp1)+acx*cjl(lp1)
            if (dimag(x).ge. 0.d0) then
              hl(ll) = (sjl(lp1)+coni*cjl(lp1)) * epx
            else
              hl(ll) = (sjl(lp1)-coni*cjl(lp1)) * epx
            endif
  110    continue
      endif

      return
      end


module global_module

! This module contains data needed throughout the program.
! Most data is specified as a parameter, as to make the execution faster.
! This module is loaded by most other modules.

  implicit none

  ! Time integration

  real(kind=8), parameter :: dt    = 1.0d-7 ! [s] time step for the simulation
  real(kind=8), parameter :: t_end = 1.0d-2 ! [s] total simulated time (from 0 to t_end)

  ! Specify domain and discretization

  real(kind=8), parameter :: x_min = -1.0 ! [m] needs to be NEGATIVE
  real(kind=8), parameter :: x_max = 2.0  ! [m] needs to be LARGER THAN PLATE LENGTH L_plate
  real(kind=8), parameter :: y_min = -1.0 ! [m] needs to be NEGATIVE
  real(kind=8), parameter :: y_max = 1.0  ! [m] needs to be POSITIVE

  ! Total number of cells (including 2 ghost cells for each side)
  ! (using 2 ghost cells makes it easy to reach second order accuracy)

  integer, parameter :: Nx = 100
  integer, parameter :: Ny = 100

  real(kind=8), parameter :: dx = (x_max-x_min)/(Nx-4)
  real(kind=8), parameter :: dy = (y_max-y_min)/(Ny-4)

  ! Flat plate inside the domain.
  ! The plate is placed with the leading edge at (x,y) = (0,0).
  ! Make sure the domain is chosen correspondingly.

  real(kind=8), parameter :: L_plate = 1 ! [m] length of the flat plate

  integer, parameter :: j_plate   = floor(Ny/(y_max - y_min)*(0 - y_min)) ! find j-index of plate
  integer, parameter :: i_1_plate = floor(Nx/(x_max - x_min)*(0 - x_min)) ! starting coordinate of plate
  integer, parameter :: i_2_plate = floor(Nx/(x_max - x_min)*(L_plate - x_min)) ! starting coordinate of plate

  ! Free stream conditions for initializing the solution
  real(kind=8) :: rho0 = 1.225   ! [kg/m3]
  real(kind=8) :: ux0  = 0.0     ! [m/s]
  real(kind=8) :: uy0  = 10000.0 ! [m/s]
  real(kind=8) :: T0   = 300.0   ! [K]

end module


c  de-redshift a spectrum by z, in log space.  this means
c  shifting wl scale by -log(1+z).

c do the shift in place, or not
c      subroutine deshiftz(spec,nsp,dw,z,specout)
      subroutine deshiftz(spec,nsp,dwlog,z)

      real spec(nsp)
      real specout(nsp)

      include 'pcredshift.h'

      dzlog = log10(1.+z)
      dindx = dzlog / dwlog
      ishift = int(dindx)
      fshift = dindx - ishift
c now ishift and fshift are the positive integer and fractional
c shifts (if z is positive).  we want to shift to lower w

      do i=1,nsp
         j1 = i + ishift
         if (spec(j1) .gt. bad .and. spec(j1+1) .gt. bad) then
            specout(i) = (1.-fshift)*spec(j1) + fshift*spec(j1+1)
         else if (spec(j1) .gt. bad) then
            specout(i) = spec(j1)
         else if (spec(j1+1) .gt. bad) then
            specout(i) = spec(j1+1)
         else
            specout(i) = bad
         end if
      end do
c to deshift in place
      do i=1,nsp
         spec(i) = specout(i)
      end do

      return
      end


c=======================================================================
c
c     subroutine RETEM
c
c     Expectation-Maximization (EM) algorithm
c     -> recover missing observations in a time series
c
c     Return data structure
c
c           n : number of points
c           p : number of assets
c
c       R(n,p) = | x(1,1), ..., x(1,p) |
c                | x(2,1), ..., -1000  |
c                | x(3,1), ..., x(3,p) |
c                |   .   , ...,   .    |
c                |   .   , ...,   .    |
c                | x(n,1), ..., x(n,p) |
c
c     where x(2,p) <= -1000 denote a missing return
c
c-----------------------------------------------------------------------
      SUBROUTINE retem ( n, p, X, miss, iwork, dwork, Y, info )
c-----------------------------------------------------------------------
c
c     INPUT
c        n      : max. number of values (n > 1)                  integer
c        p      : number of assets (p > 0)                       integer
c        X      : returns values (n*p)                            double
c        miss   : missing value (<= -1)                           double
c
c     WORKSPACE
c        iwork  : 2*p                                            integer
c        dwork  : p*(13*p + 2*n + 10)                             double
c
c     OUTPUT
c        Y      : EM-recoved returns values (n*p)                 double
c        info   : diagnostic argument                            integer
c
c     CALL
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, info
      DOUBLE PRECISION miss, X(n,*), Y(n,*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER t, i, j, k, l, m, nobs, mt, nt, mtt, h
      INTEGER MaxLoop, CountLoop, Convergence
      INTEGER pindMiss, pindObs
      INTEGER pdX, pdy,
     &        pdrho, pdrhoN, pdrhoMiss, pdrhoObs,
     &        pdcov, pdcovN, pdcovm,
     &        pdyMiss, pdyObs, pdM, pdyM, pdv,
     &        pdcovMO, pdcovMM, pdcovOO, pdinvCovOO, pdjms,
     &        pdCC, pdM1, pdM2, pdM3, pdMt, pdC
      DOUBLE PRECISION Tolerance, Distance, tmp, EPS, ZERO
      PARAMETER (EPS = 1.E-15, ZERO = 0.0)
c
c     external subroutines
      EXTERNAL IVX, YM, MCM, covm
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
      CALL YM ( n, p, X, Y ) ! copy X -> Y
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      pindMiss = 1
c     pindMiss : pointer missing data index (p)
      pindObs  = pindMiss + ( p )
c     pindObs  : pointer observed data index (p)
c
c     Total size of iwork array  = 2*p
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdX    = 1
c     pdX    : pointer for availaible NAV (n*p)
      pdrho  = pdX + ( n*p )
c     pdrho  : pointer for mean vector (p)
      pdrhoN = pdrho + ( p )
c     pdrhoN : pointer for new mean vector (p)
      pdcov  = pdrhoN + ( p )
c     pdcov  : pointer for covariance matrix (p*p)
      pdcovN = pdcov + ( p*p )
c     pdcovN : pointer for new covariance matrix (p*p)
      pdcovm = pdcovN + ( p*p )
c     pdcovm : pointer for COVM (p*n + p)
      pdy    = pdcovm + ( n*p + p)
c     pdy    : pointer (p)
      pdyMiss = pdy + ( p )
c     pdyMiss : pointer missing data y (p)
      pdyObs  = pdyMiss + ( p )
c     pdyObs  : pointer observed data y (p)
      pdM     = pdyObs + ( p )
c
      pdyM    = pdM + ( p )
c
      pdv     = pdyM + ( p )
c
      pdrhoMiss  = pdv + ( p )
c     pdrhoMiss  : pointer missing mean (p)
      pdrhoObs   = pdrhoMiss + ( p )
c     pdrhoObs   : pointer observed mean (p)
      pdcovMO    = pdrhoObs + ( p )
c     pdcovMO    : pointer missing/observed cov (p*p)
      pdcovMM    = pdcovMO + ( p*p )
c     pdcovMM    : pointer missing/missing cov (p*p)
      pdcovOO    = pdcovMM + ( p*p )
c     pdcovOO    : pointer observed/observed cov (p*p)
      pdinvCovOO = pdcovOO + ( p*p )
c     pdinvCovOO : pointer observed/observed inverse cov (p*p)
      pdCC       = pdinvCovOO + ( p*p )
c
      pdM1       = pdCC + ( p*p )
c
      pdM2       = pdM1 + ( p*p )
c
      pdM3       = pdM2 + ( p*p )
c
      pdMt       = pdM3 + ( p*p )
c
      pdC        = pdMt + ( p*p )
c
      pdjms      = pdC + ( p*p )
c     pdjms      : pointer for JMS (p*p)
c
c     Total size of dwork array  = p*(13*p + 2*n + 10)
c
c-----------------------------------------------------------------------
c
c     E-M initialization
      h  = 1       ! horizon (log-returns
      m  = 0       ! number of missing data (one by row)
      DO t = 1,n
        DO i = 1,p
            IF (X(t,i) .LE. miss) THEN
                m = m + 1
                GOTO 100
            ENDIF
        ENDDO
  100 CONTINUE
      ENDDO
      IF (m .EQ. 0) RETURN ! if no missing data -> exit
      nobs = n - m         ! number of available dat
      IF (nobs .EQ. 0) THEN
        info = -9003 ! no enough available data for initialization
        RETURN
      ENDIF
c
      k = 0
      DO t = 1,n
        DO i = 1,p
            IF (X(t,i) .LE. miss) GOTO 101
        ENDDO
        k = k + 1
        DO i = 1,p
            dwork(pdX + nobs*(i-1) + k - 1) = X(t,i)
        ENDDO
  101 CONTINUE
      ENDDO
c
c     mean and cov. matrix
      CALL MCM (nobs,p,dwork(pdX),dwork(pdrho))
      CALL YV (p,dwork(pdrho),dwork(pdrhoN))
      CALL covm (nobs,p,dwork(pdX),dwork(pdcovm),dwork(pdcov),info)
c
      CALL YV (p*p,dwork(pdcov),dwork(pdcovN))
      IF (info .LT. 0) RETURN
c
c     EM loop
      tmp = dwork(pdrhoN) + SQRT(MAX(dwork(pdcovN),EPS))
      DO i = 2,p
        tmp = tmp + dwork(pdrhoN+i-1) +
     &        SQRT(MAX(dwork(pdcovN+p*(i-1)+i-1),EPS))
      ENDDO
      Tolerance = 1.E-6*(tmp/(2.0*p)) ! algorithm tolerance
      MaxLoop     = 100  ! maximum EM loop
      CountLoop   = 0    ! loop counter
      Convergence = 0    ! convergence test (0 no, 1 yes)
      DO WHILE ((Convergence .EQ. 0).AND.(CountLoop.LT.MaxLoop))
        CountLoop = CountLoop + 1  ! counter + 1
        CALL YV (p, dwork(pdrhoN), dwork(pdrho))
        CALL YV (p*p, dwork(pdcovN), dwork(pdcov))
c
c       Step 1: estimation
        CALL IVX (p*p, dwork(pdC), ZERO)
        CALL IVX (p*p, dwork(pdMt), ZERO) ! Mt = zeros(p,p)
        DO t = 1,n
             mt = 0 ! number of missing data at time t
             nt = 0 ! number of observed data at time t
             CALL IVX (p*p, dwork(pdCC), ZERO) ! CC = zeros(p,p)
             DO i = 1,p
                dwork(pdy + i - 1) = X(t,i)
                IF (X(t,i) .LE. miss) THEN
                    dwork(pdyMiss + mt)   = dwork(pdy+i-1)
                    iwork(pindMiss + mt)  = i ! index of missing data
                    dwork(pdrhoMiss + mt) = dwork(pdrho + i - 1)
                    mt = mt + 1 ! number of missing data at time t
                ELSE
                    dwork(pdyObs + nt)   = dwork(pdy+i-1) ! observation
                    iwork(pindObs + nt)  = i ! index of observed data
                    dwork(pdrhoObs + nt) = dwork(pdrho + i - 1)
                    nt = nt + 1 ! number of observed data at time t
                ENDIF
            ENDDO
c
c           if all data are missing at date t -> exit
            IF (mt .EQ. p) THEN
                info = -9001
                RETURN
            ENDIF
            IF ((mt .GT. 0).AND. (nt .GT. 0)) THEN ! if missing data
c
c           construct cov. matrix for miss and observed data
c           cov[missing,obs] : vector of missing vs. observed covariances
c           cov[obs,obs]     : matrix of observed covariances
c           cov[missing,missing] : matrix of missing covariances
            DO i = 1,mt
                k = iwork(pindMiss + i - 1)
                DO j = 1,nt
                    l = iwork(pindObs + j - 1)
                    dwork(pdcovMO + mt*(j-1) + i-1) =
     &              dwork(pdcov + p*(k-1) + l-1)
                ENDDO
            ENDDO
            CALL YMCPI ( p, dwork(pdcov), mt, iwork(pindMiss),
     &                   dwork(pdcovMM), info)
            CALL YMCPI ( p, dwork(pdcov), nt, iwork(pindObs),
     &                   dwork(pdcovOO), info)
            CALL JMS (nt,dwork(pdcovOO),dwork(pdjms),dwork(pdinvCovOO),
     &                info)
            IF (info .NE. 0) THEN
                info = -108 ! matrix is not sdp
                RETURN
            ENDIF
c
c           y(Miss) = M(Miss)+S(Miss,Obs)*inv(S(Obs,Obs))*(y(Obs)-M(Obs)
            CALL DV(nt,dwork(pdyObs),dwork(pdrhoObs),dwork(pdM))
            CALL PMV(nt,nt,dwork(pdinvCovOO),dwork(pdM),dwork(pdyM))
            CALL PMV(mt,nt,dwork(pdcovMO),dwork(pdyM),dwork(pdv))
            CALL SV(mt,dwork(pdrhoMiss),dwork(pdv),dwork(pdyMiss))

c
c           c(Miss,Miss) = S(Miss,Miss)-S(Miss,Obs)*inv(S(Obs,Obs))*S(Obs,Miss)
c           C(m,n) =  A(m,k) * B(k,n)
            CALL PM (mt,nt,nt,dwork(pdcovMO),dwork(pdinvCovOO),
     &                dwork(pdM1))
c           C(m,n) = A(m,k) * B'(n,k)
            CALL PMMT (mt,nt,mt,dwork(pdM1),dwork(pdcovMO),dwork(pdM2))
c           C(m,n) = A(m,n) - B(m,n)
            CALL DM (mt,mt,dwork(pdcovMM),dwork(pdM2),dwork(pdM3))
            DO i = 1,mt
                k = iwork(pindMiss + i - 1)
                DO j = 1,mt
                    l = iwork(pindMiss + j - 1)
                    dwork(pdCC + p*(k-1) + l - 1) =
     &              dwork(pdM3 + mt*(i-1) + j - 1)

                ENDDO
            ENDDO
            CALL SV (p*p, dwork(pdCC), dwork(pdMt), dwork(pdC))
            CALL YV (p*p, dwork(pdC), dwork(pdMt))
c
            mtt = 0
            DO i = 1,p
                IF (X(t,i) .LE. miss) THEN
                    mtt = mtt + 1
c                   replace missing data
                    dwork(pdy + mtt - 1) =
     &              MAX(dwork(pdyMiss + mtt - 1),0.0)
	              Y(t,i) = dwork(pdy + mtt - 1)
	            ENDIF
      		ENDDO
         ENDIF
       ENDDO
c
c       Step 2: update
c       update mean rho_new = mean(Y)
        CALL MCM (n,p,Y,dwork(pdrhoN))
        tmp = 1.0/n
c       update cov. matrix
        CALL IVX (p*p, dwork(pdM1), ZERO) ! M1 = zeros(p,p)
        CALL IVX (p*p, dwork(pdM2), ZERO) ! M2 = zeros(p,p)
        CALL IVX (p*p, dwork(pdM3), ZERO) ! M3 = zeros(p,p)
        CALL PVX (p*p, dwork(pdC), tmp, dwork(pdM1))
        CALL COVM (n,p,Y,dwork(pdcovm),dwork(pdM2),info)
        tmp = (n-1.0)/n
        CALL PVX (p*p, dwork(pdM2), tmp, dwork(pdM3))
        CALL SV (p*p, dwork(pdM1), dwork(pdM3), dwork(pdcovN))
c
c       test of algorithm convergence (mean and covariance matrix)
        CALL IVX (p, dwork(pdv), ZERO)    ! v = zeros(p)
        CALL IVX (p*p, dwork(pdM1), ZERO) ! M1 = zeros(p,p)
        CALL DV ( p, dwork(pdrho), dwork(pdrhoN), dwork(pdv) )
        CALL DV ( p*p, dwork(pdcov), dwork(pdcovN), dwork(pdM1) )
c       D4=[(M_new - M).^4; diag((S_new - S).^2) ]
        tmp = dwork(pdv) + dwork(pdM1)
        DO i = 2,p
            tmp = tmp + dwork(pdv+i-1)**4 + dwork(pdM1+p*(i-1)+i-1)**2
        ENDDO
c       Distance= mean(D4.^(1/4))
        Distance = SQRT(tmp/(2.0*p))
        Distance = SQRT(Distance)
        IF (Distance .LT. Tolerance) Convergence = 1
      ENDDO ! end while
c
      RETURN
      END


PROGRAM calc_observables

  ! Program reads data from sgd_grid
  ! calculates astronomical observables for the model grid
  ! Assumes a dust temperature and opacity properties to do so

  use eosdata
  implicit none

  integer :: irad,imdot,irrchoice
  integer :: nrad, nmdot

  real :: beta_k,distance, lambda0,kappa0,lambda,Tdust
  real :: Mstar, metallicity, gamma_sigma,gamma_omega
  real :: nu0, nu, kappa_nu,flux_nu,fluxtot,mflux
  real :: rmin, rmax, mdotmin,mdotmax, mdotvisc
  real :: Q_irr, T_irr, r, qratio,mtot
  real :: sigma, omega, T, cs,betac,alpha,dr

  character(100) ::inputfile,inputprefix, outputfile

  !*******************************************
  ! 1. Get input parameters and set up header:
  !*******************************************

  print*, " "
  print*, "-----------------------------------------------"
  print*, " OBSERVABLES FROM SELF-GRAVITATING DISC MODELS "
  print*, "     Created by D. Forgan, Jan 2013            "
  print*, "     Current Version: Jan 2018"
  print*, " (Relies on input from sgd_grid) "
  print*, "-----------------------------------------------"
  print*, " "
  print*, " "
  print*, " input files: ./calc_observables.params"
  print*, " "
  print*, "-----------------------------------------------"
  print*, " "

  OPEN(10,file='calc_observables.params', status='unknown')
  read(10,*) inputprefix
  READ(10,*) outputfile
  READ(10,*) distance
  READ(10,*) lambda  ! Input in nanometres
  READ(10,*) kappa0
  read(10,*) lambda0 ! input in nanometres
  read(10,*) beta_k
  read(10,*) Tdust
  close(10)

  ! Convert wavelengths into cm
  lambda = lambda*1e-4
  lambda0 = lambda0*1e-4

  inputfile = trim(inputprefix)//'.sgdmodel'
  print*, 'Reading file ', inputfile
  outputfile = trim(inputprefix)//'.observe'
  print*, 'Outputting to file ', outputfile

  OPEN(10,file=inputfile ,status='unknown')
  read(10,*) nrad, nmdot, rmin,rmax,mdotmin,mdotmax,Mstar, metallicity,gamma_sigma,gamma_omega,irrchoice,Q_irr,T_irr

  dr = (rmax-rmin)/REAL(nrad)
  dr = dr*udist
  distance = distance*pc
  nu = c/lambda
  nu0 = c/lambda0
  kappa_nu = kappa0*(nu/nu0)**(beta_k)

  OPEN(20,file=outputfile,status='unknown')
  write(20,*) nrad,nmdot,nu,lambda*1e4, rmin, rmax,mdotmin,mdotmax,Mstar,metallicity,gamma_sigma,gamma_omega,irrchoice,Q_irr,T_irr

  !**************************
  ! 2. Compute observables
  !**************************

  ! Loop over parameters

  DO imdot = 1, nmdot

     mtot = 0.0
     fluxtot = 0.0

     ! Loop over radii
     DO irad = 1,nrad

        read(10,*) r, mdotvisc, qratio, sigma, cs,omega,T,betac,alpha

        r = r*udist

        ! Calculate flux generated in this annulus

        if (sigma*kappa_nu < 1.0) THEN
           flux_nu = (2.0*Boltzmannk/(c*c))*nu*nu*kappa_nu*sigma*T*twopi*r*dr/(distance*distance)
        else
           flux_nu = (2.0*Boltzmannk/(c*c))*nu*nu*(T/(sigma*kappa_nu)**0.25)*twopi*r*dr/(distance*distance)

        ENDIF

        ! Calculate total flux emitted up to and including this radius

        mtot = qratio*Mstar
        fluxtot = fluxtot + flux_nu

        ! Calculate predicted mass from the observed flux
        ! (given estimated dust temperature and assuming optically thin)

        mflux = distance*distance*fluxtot*c*c/(2.0*kappa_nu*nu*nu*Boltzmannk*Tdust)

        !********************
        ! 3.	Write to file
        !********************

        ! flux output in mJy

        WRITE(20,*) r/udist, mdotvisc, qratio,mtot, flux_nu/1e-26, fluxtot/1e-26,mflux/umass, mflux/(umass*mtot)

     ENDDO
  ENDDO

  close(10)
  close(20)

END PROGRAM calc_observables


subroutine compute_planet_torques
  !
  ! For each planet, compute the torque it exerts on the disc
  ! cf Nayakshin (2014)
  !

  use planetdata
  use gravdata
  use unitdata

  implicit none

  integer :: iplanet,i
  real :: rhill,mratio,deltap, Pcrit, typeInorm
  real :: tmig1, lambda_dash, deltamax,aspectratio, softenfactor
  logical :: soften

  call find_planets_in_disc

  torquei(:,:) = 0.0
  total_planet_torque(:) = 0.0
  torque_term(:) = 0.0

  ! Loop over each planet
  do iplanet =1,nplanet

     mratio = mp(iplanet)/Mstar
     rhill = ap(iplanet)*(mratio/3.0)**0.333

     typeInorm = 0.0

     !**************************************************************
     ! Compute Type II and Type I torques (appropriately normalised)
     !**************************************************************

     do i = isr,ier

        !*****************************************************
        ! Compute the Type II specific torque at this radius
        !*****************************************************

        deltap = abs(rz(i)-ap(iplanet))

        deltamax = H(i)

        soften = .false.
        if(1.44*rhill>deltamax) deltamax = 1.44*rhill

        if(deltap<deltamax) then
           deltap =deltamax
           soften = .true.
        endif

        lambdaII(iplanet,i) = 0.5*mratio*mratio/(deltap)**4
        if(rz(i) < ap(iplanet)) then
           lambdaII(iplanet,i) = -lambdaII(iplanet,i)*(rz(i))**4
        else
           lambdaII(iplanet,i) = lambdaII(iplanet,i)*(ap(iplanet))**4
        endif

        if(soften) then

           softenfactor = abs(rz(i)-ap(iplanet))/deltamax
           if(softenfactor < 0.0001) softenfactor = 0.0001
           lambdaII(iplanet,i)=lambdaII(iplanet,i)*softenfactor
        endif

        !*************************************
        ! Compute the Type I specific torque (cf Nayakshin)
        !*************************************

        ! Must first compute the total torque and then normalise
        ! to obtain the correct Type I migration timescale

        ! Integrate the torque over all radii

        if(rz(i)<ap(iplanet)) then
           typeInorm = typeInorm + exp(-deltap/(H(i)+rhill))*sigma(i)/drzm1(i)
        else
           typeInorm = typeInorm + exp(-deltap/(H(i)+rhill))*sigma(i)/drzm1(i)
        endif

     enddo

     ! Compute Type I migration timescale
     call calc_typeI_migration(iplanet,tmig1)

     ! Find normalisation constant to ensure correct Type I timescale

     if(tmig1 > 1.0e-30) then
        lambda_dash = mp(iplanet)/(omegaK(iplanetrad(iplanet))*ap(iplanet)*4.0*pi*tmig1*typeInorm)
      else
        lambda_dash = 0.0
      endif

     ! Now compute functional form of lambda
     ! (assuming concentration of torque in planet local vicinity)
     do i=isr,ier

        deltap = abs(rz(i)-ap(iplanet))

        if(deltap<H(i)) deltap =H(i)
        if(deltap<rhill) deltap=rhill

        lambdaI(iplanet,i) = lambda_dash*exp(-deltap/(H(i)+rhill))

        !if(rz(i)<ap(iplanet)) lambdaI(iplanet,i) = -lambdaI(iplanet,i)

     enddo

     !**************************************************
     ! Now compute the relative dominance of each torque
     !**************************************************

     Pcrit = 0.75 * H(iplanetrad(iplanet))/rhill + 50.0*alpha_g(iplanetrad(iplanet))*(H(iplanetrad(iplanet))/ap(iplanet))**2/mratio

     fII(iplanet) = exp(-Pcrit+1.0)
     if(fII(iplanet) > 1.0) fII(iplanet)=1.0

      !********************************************************
      ! Compute the total effective planet torque at this radius
      !*********************************************************

     torquei(iplanet,:) = lambdaI(iplanet,:)*(1.0-fII(iplanet)) + lambdaII(iplanet,:)*fII(iplanet)

     ! Add planet contribution to the total torque exerted on the disc

     total_planet_torque(:) = total_planet_torque(:) + torquei(iplanet,:)

  enddo

  ! Ensure torque magnitude does not exceed maximum permitted value
  ! (Alexander & Armitage 2009, ApJ, 704, 989)

  do i=isr,ier
     aspectratio = H(i)/rz(i)

     if(abs(total_planet_torque(i)) > 0.1*aspectratio) then
        total_planet_torque(i) = 0.1*aspectratio*total_planet_torque(i)/abs(total_planet_torque(i))

        !print*, rz(i)/AU, aspectratio, total_planet_torque(i)
     endif
  enddo

  ! Set brief time delay for planet torque activation

  if(t < tdelay_planettorque*yr) then
     total_planet_torque(:) = total_planet_torque(:)*1.0e-30
  endif

   torque_term(:) = 2.0*omegaK(:)*rf(:)*rf(:)*sigma(:)*total_planet_torque(:)

   ! Zero torque_term at planet locations

   do iplanet=1,nplanet
      torque_term(iplanetrad(iplanet)) = 0
      torque_term(iplanetrad(iplanet)+1) = 0
   enddo

end subroutine compute_planet_torques