c
c subroutine triaxcoef
c
c Function extracted from program TRICOEF.COM by Jean Lorre.
c
c	Date extracted:		October 1993
c	Extracted by:		Justin McNeill
c
c This has been modified to now include both authalic as well as conformal
c auxiallary coefficient functionality. Code was adopted from Jean Lorre's
c tricoef routine. Recent changes also made in the randum number generator
c function, to 'rangen', to correct for errors occurring on the sgi system
c with the older 'ran1' function   -  pxa  august '96

c oct96 -lwk- hard-coded the random-number seed in order to allow comparison
c		of test logs;  this will be replaced in the future by
c		allowing the user to specify this (as well as the 3 limits),
c		which will require a new routine to give the user access

c jun98 -lwk- replaced rangen with modified version of RAN1 because of
c		problems on DEC-Unix
c aug98 -lwk- made all xvmessage calls dependent on flag.eq.1 (except for
c		one initial one)

      subroutine triaxcoef( radii,cc,cp,ac,ap,nlimit,mlimit,klimit,
     +	flag,status)
      implicit real*8 (a-h,o-z)
      real*8 cc(nlimit,mlimit),cp(nlimit,mlimit)
      real*8 ac(0:mlimit,0:klimit),ap(nlimit)
      parameter (maxpts=800) ! Changes must be made in other places too !
      parameter (maxeqs=400)
      parameter (latpts=72,lonpts=72)
      character*80 msg
      character*12 planet
      integer*4 flag
      integer*4 count,status
      real*4 rannum, ran1
      real*8 radii(3),radsph
      real*8 lat(maxpts),lon(maxpts)
      real*8 costheta(maxpts),sintheta(maxpts),f(maxpts)
      real*8 amatrix(maxeqs*maxeqs),bvector(maxeqs)
      real*8 authcoef1(maxpts),authcoef2(maxpts)

      common/c1/a,b,c,lat,lon,costheta,sintheta,f

c initialize spice for planet radii retrieval.
c      call init_spice
c
c parameters
      planet='            '
      a=0.d0
c     call xvparmd('RADIUS',radii,count,def,3)

      count = 3

      if(count.gt.0)then
        a=radii(1)
        b=radii(2)
        c=radii(3)
      endif
c      call xvparm('PLANET',planet,count,def,1)

      count = 0

c      if(count.eq.1)then
c      call ccase(planet,1)
c        call getplacon(planet,id,planet_data,ind)
c        if(ind.ne.0)then
c           call xvmessage('GETPLACON: unrecognizable planet',' ')
c           call xvmessage('Input name is:'//planet,' ')
c           if(a.eq.0.d0) call abend
c        endif
c        call xvmessage('Name will be placed in coefficnt file',' ')
c        a=planet_data(1)
c        b=planet_data(2)
c        c=planet_data(3)
c      endif
c
c      call xvparmd('RADIUS',radii,count,def,3)
c
c      if(count.gt.0)then
c       a=radii(1)
c       b=radii(2)
c       c=radii(3)
c     endif
c      call xvparm('MLIMIT',mlimit,count,def,1)
c      call xvparm('NLIMIT',nlimit,count,def,1)

      if (flag.eq.1) then
        write(msg,108)a,b,c
108     format('Planet radii a,b,c:',3f10.2)
c        call xvmessage(msg,' ')
      else
c	call xvmessage(' Computing triaxial coefficients ...',' ')
      endif

      if(a.eq.0.d0)then
         call xvmessage('Planet radii unspecified',' ')
         status = -401
         return
c         call abend
      endif
      if((c.ge.b).or.(b.ge.a))then
         call xvmessage('Radii out of order, should be decreasing.',' ')
         call xvmessage('Oblate spheroids not supported.',' ')
         status = -402
         return
c         call abend
      endif
      c=c/a
      b=b/a
      a=1.d0

      nequations=nlimit*mlimit*2
      if(nequations.gt.maxeqs)then
         call xvmessage('Too many equations requested',' ')
         write(msg,100) maxeqs
100      format(' Maximum number of equations = ',i5)
         call xvmessage(msg,' ')
         status = -403
         return
c         call abend
      else
	 if (flag.eq.1) then
          write(msg,110) nequations
110       format(i4,' simultaneous equations.')
          call xvmessage(msg,' ')
         endif
      endif

      npoints=nequations*2           ! npoints > nequations/2 (Snyder).
      if(npoints.gt.maxpts)then
         npoints=maxpts
	 if (flag.eq.1) then
          call xvmessage('Warning: #points must be > #equations/2',' ')
          write(msg,102) nequations
102       format(' Number of equations = ',i5)
          call xvmessage(msg,' ')
         endif
      endif
      if (flag.eq.1) then
       write(msg,111) npoints
111    format(i4,' random points selected to fit equations.')
       call xvmessage(msg,' ')
      endif

c compute the fit points from a random grid in the range lat=0 to 85
c long=0 to 90.
      idum=-768825576		! establish a seed for random numbers
c      call get_seconds(idum)
c      if (flag.eq.1) then
c      write(msg,112) idum
c112    format(' The random number seed = ',i10)
c       call xvmessage(msg,' ')
c      endif
      degtorad=datan(1.0d0)/45.d0
      do i=1,npoints
	rannum = ran1(idum)
	lat(i)=degtorad*85.*rannum
	rannum = ran1(idum)
	lon(i)=degtorad*90.*rannum
      enddo

      if (flag.eq.1) then
        call xvmessage('Printing out random Lat/Lon values ...',' ')
        do i=1,npoints
          write(msg,101) lat(i), lon(i)
          call xvmessage(msg,' ')
        enddo
        call xvmessage(' ',' ')
        call xvmessage('Printing out intermediate values ...',' ')
      endif

c compute & save values unique to each point.
      do i=1,npoints
         flon=(dsin(lon(i)))**2+((b*b)/(a*a))*(dcos(lon(i)))**2    ! eqn 9
         flat=(dsin(lat(i)))**2+((c*c)/(b*b))*(dcos(lat(i)))**2    ! eqn 10
         t1=(1.d0-(b*b)/(a*a))*dsin(lon(i))*dcos(lon(i))*dsin(lat(i))
         t2=(dsin(lat(i)))**2+(c**4/b**4)*flon*(dcos(lat(i)))**2
         t3=(dsin(lon(i)))**2+(b**4/a**4)*(dcos(lon(i)))**2
         costheta(i)=t1/(dsqrt(t2)*dsqrt(t3))                      ! eqn 48
         sintheta(i)=dsin(dacos(costheta(i)))
         f(i)=dcos(lat(i))*dsqrt(t3)*flat/(flon*dsqrt(t2))         ! eqn 50
         if (flag.eq.1) then
           write(msg,105) costheta(i), sintheta(i), f(i)
           call xvmessage(msg,' ')
         endif
      enddo

c load matrices to do the linear fit.                              ! eqn 80
      ip=1
      iq=0
      do i=1,mlimit*nlimit       ! first 1/2 of equations loop

         j=i
         m=1
         n=0
         do k=1,mlimit*nlimit    ! first 1/2 of terms in equation
            t=0.d0
            do ii=1,npoints
               t=t+p1(m,n,ii)*p1(ip,iq,ii)+p3(m,n,ii)*p3(ip,iq,ii)
            enddo
            if(n.eq.nlimit-1)then
               n=0
               m=m+1
            else
               n=n+1
            endif
            amatrix(j)=t
            j=j+nequations
         enddo

         m=0
         n=1
         do k=mlimit*nlimit+1,nequations         ! second 1/2 of terms
            t=0.d0
            do ii=1,npoints
               t=t+p2(m,n,ii)*p1(ip,iq,ii)+p4(m,n,ii)*p3(ip,iq,ii)
            enddo
            if(n.eq.nlimit)then
               n=1
               m=m+1
            else
               n=n+1
            endif
            amatrix(j)=t
            j=j+nequations
         enddo

         t=0.d0
         do ii=1,npoints
            t=t+(f(ii)/dcos(lat(ii))-sintheta(ii))*p1(ip,iq,ii)+
     +        (1.d0-f(ii)*sintheta(ii)/dcos(lat(ii)))*p3(ip,iq,ii)
         enddo
         bvector(i)=t
         if(iq.eq.nlimit-1)then
            iq=0
            ip=ip+1
         else
            iq=iq+1
         endif

      enddo

c      ip=1
c      iq=0
      ip=0
      iq=1
      do i=mlimit*nlimit+1,nequations       ! second 1/2 of equations loop

         j=i
         m=1
         n=0
         do k=1,mlimit*nlimit    ! first 1/2 of terms in equation
            t=0.d0
            do ii=1,npoints
               t=t+p1(m,n,ii)*p2(ip,iq,ii)+p3(m,n,ii)*p4(ip,iq,ii)
            enddo
            if(n.eq.nlimit-1)then
               n=0
               m=m+1
            else
               n=n+1
            endif
            amatrix(j)=t
            j=j+nequations
         enddo

         m=0
         n=1
         do k=mlimit*nlimit+1,nequations         ! second 1/2 of terms
            t=0.d0
            do ii=1,npoints
               t=t+p2(m,n,ii)*p2(ip,iq,ii)+p4(m,n,ii)*p4(ip,iq,ii)
            enddo
            if(n.eq.nlimit)then
               n=1
               m=m+1
            else
               n=n+1
            endif
            amatrix(j)=t
            j=j+nequations
         enddo

         t=0.d0
         do ii=1,npoints
c            if(i.eq.5)write(*,*)ip,iq,p2(ip,iq,ii),p4(ip,iq,ii)
            t=t+(f(ii)/dcos(lat(ii))-sintheta(ii))*p2(ip,iq,ii)+
     +        (1.d0-f(ii)*sintheta(ii)/dcos(lat(ii)))*p4(ip,iq,ii)
         enddo
         bvector(i)=t
c         if(iq.eq.nlimit-1)then
c            iq=0
         if(iq.eq.nlimit)then
            iq=1
            ip=ip+1
         else
            iq=iq+1
         endif

      enddo

      if (flag.eq.1) then

c print the a-matrix
        call xvmessage('A-matrix terms by row..',' ')
        do i=1,nequations*nequations,nequations
          do j=i,i+nequations-1,6
            m=j+5
            if(m.gt.i+nequations-1) m=i+nequations-1
            write(msg,104)(amatrix(k),k=j,m)
104         format(6f13.0)
            call xvmessage(msg,' ')
          enddo
        enddo

c print the b-vector

        call xvmessage('B-vector terms top down..',' ')
        do j=1,nequations,8
          m=j+7
          if(m.gt.nequations)m=nequations
          write(msg,101)(bvector(k),k=j,m)
101       format(8f10.4)
          call xvmessage(msg,' ')
        enddo

      endif

C       k=1
C       do i=1,nequations
C          check(i)=amatrix(k)
C          k=k+nequations
C       enddo
C       result=bvector(1)

c perform the solution.
      if (flag.eq.1) then
       call xvmessage('Beginning matrix solution.',' ')
      endif
      call mp_dsimq(amatrix,bvector,nequations,ks)
      if(ks.ne.0)then
         call xvmessage('Ill conditioned equations, no solution.',' ')
	 status = -1
         return
      endif

c      r=0.d0
c      do i=1,nequations
c         r=r+bvector(i)*check(i)
c      enddo
c      write(*,*)'should,actual ',result,r

c print terms
      if (flag.eq.1) then
        call xvmessage('C(m,n) coefficients. Rows m=1,2,3,...',' ')
        call xvmessage('Columns begin at n=0,1,2,3...',' ')
      endif
      m=0
      do i=1,mlimit*nlimit,nlimit
         m=m+1
         do j=i,i+nlimit-1,5
            l=j+4
            if(l.gt.i+nlimit-1) l=i+nlimit-1
	    if (flag.eq.1) then
              write(msg,105)(bvector(k),k=j,l)
105           format(5f16.11)
              call xvmessage(msg,' ')
	    endif
         enddo
      enddo
      if (flag.eq.1) then
         call xvmessage('C(m,n)primed coefficients. Rows m=0,1,2,...',
     &    ' ')
         call xvmessage('Columns begin at n=1,2,3...',' ')
      endif
      m=-1
      do i=mlimit*nlimit+1,nequations,nlimit
         m=m+1
         do j=i,i+nlimit-1,5
            l=j+4
            if(l.gt.i+nlimit-1) l=i+nlimit-1
	    if (flag.eq.1) then
              write(msg,105)(bvector(k),k=j,l)
              call xvmessage(msg,' ')
	    endif
         enddo
      enddo

c Recompute NPOINTS random points for RMS error computation.
c The same points won't do since we've fitted to them.

      do i=1,npoints
	rannum = ran1(idum)
	lat(i)=degtorad*85.*rannum
	rannum = ran1(idum)
	lon(i)=degtorad*90.*rannum
      enddo
      do i=1,npoints
         flon=(dsin(lon(i)))**2+((b*b)/(a*a))*(dcos(lon(i)))**2    ! eqn 9
         flat=(dsin(lat(i)))**2+((c*c)/(b*b))*(dcos(lat(i)))**2    ! eqn 10
         t1=(1.d0-(b*b)/(a*a))*dsin(lon(i))*dcos(lon(i))*dsin(lat(i))
         t2=(dsin(lat(i)))**2+(c**4/b**4)*flon*(dcos(lat(i)))**2
         t3=(dsin(lon(i)))**2+(b**4/a**4)*(dcos(lon(i)))**2
         costheta(i)=t1/(dsqrt(t2)*dsqrt(t3))                      ! eqn 48
         sintheta(i)=dsin(dacos(costheta(i)))
         f(i)=dcos(lat(i))*dsqrt(t3)*flat/(flon*dsqrt(t2))         ! eqn 50
      enddo

c compute rms error for the coefficient set.
      if (flag.eq.1) then
        call xvmessage('    ',' ')
        call xvmessage('The RMS error is the constraint violation',' ')
        call xvmessage('ie: angle and scale or equal area    ',' ')
      endif
      call rmserror(bvector,bvector(mlimit*nlimit+1),
     +              nlimit,mlimit,npoints,rms)
      if (flag.eq.1) then
        write(msg,106)rms
106     format(' Rms error using these coefficients is ',f15.11)
        call xvmessage(msg,' ')
      endif
c
c abandon coefficients
c      if(planet.eq.'            ') then
c        call xvmessage('Coefficients discarded',' ')
c        return
c     endif
c
c save coefficients

       k=0
       m=0
       if (flag.eq.1) then
	call xvmessage('These are the loaded cc,cp arrays...',' ')
       endif
       do i=1,nlimit
	 k=m*nlimit
         do j=1,mlimit
		cc(i,j)=bvector(j+k)
	        cp(i,j)=bvector(nlimit*mlimit+j+k)
c		type *,i,j,cc(i,j),cp(i,j)
	        if (flag.eq.1) then
		  write(msg,107) i,j,cc(i,j),cp(i,j)
107		  format(i4,i4,f16.11,f16.11)
		  call xvmessage(msg,' ')
		endif
         enddo
	 m=m+1
       enddo
c      endif

c *******************************************************
c compute authalic coefficients : authcoef1 & 2
c *******************************************************
      call authalic_coef(a,b,c,mlimit,klimit,nlimit,
     + 	amatrix(1),
     +  amatrix((latpts+1)*(lonpts+1)+1),
     +  amatrix((latpts+1)*(lonpts+1)*2+1),
     +  authcoef1,authcoef2,radsph)
c	print terms
      if (flag.eq.1) then
	call xvmessage('Authalic Case:',' ')
	call xvmessage('COEF(m,k) coefficients. Rows m=0,1,2...',' ')
	call xvmessage('Columns begin at k=0,1,2,....',' ')
	do k=1,(klimit+1)*(mlimit+1),mlimit+1
	  do i=k,k+mlimit,5
	    ii=i+4
	    if(ii.gt.k+mlimit) ii=k+mlimit
		write (msg,105) (authcoef1(j),j=i,ii)
		call xvmessage(msg,' ')
	   enddo
	enddo
	call xvmessage('COEFP(n) coefficient array. n=0,1,2,....',' ')
	do i=1,nlimit,5
	   ii=i+4
	   if(ii.gt.nlimit) ii=nlimit
	   write (msg,105) (authcoef2(j),j=i,ii)
	   call xvmessage(msg,' ')
	enddo
	write(msg,117)radsph
117	format('Radius of equivalent area sphere is ',f16.8)
	call xvmessage(msg,' ')
      endif

c compute rms error for the coefficient set
      if (flag.eq.1) then
        call xvmessage('     ',' ')
        call xvmessage('The RMS error is the constraint violation',' ')
        call authalic_rmserror(authcoef1,authcoef2,nlimit,klimit,mlimit,
     +		radsph,degtorad,a,b,c,rms)
        write(msg,116)rms
116     format('Authalic rms error using these coefficients is ',f15.11)
        call xvmessage(msg,' ')
      endif

c save coefficients
      k=0
      if (flag.eq.1) call xvmessage('Loaded ac array...',' ')
      do i=0,mlimit,1
	do j=0,klimit,1
	  ac(i,j)=authcoef1(k+1)
	  if (flag.eq.1) then
	    write(msg,135) i,j,ac(i,j)
135	    format(i4,i4,f16.11)
	    call xvmessage(msg,' ')
	  endif
	  k=k+1
	enddo
      enddo
      if (flag.eq.1) call xvmessage('Loaded ap array...',' ')
      do i=1,nlimit,1
	ap(i)=authcoef2(i)
	if (flag.eq.1) then
		write(msg,136) i,ap(i)
136		format(i4,f16.11)
		call xvmessage(msg,' ')
	endif
      enddo

      status=0

      return
      end

c ********************************************************************
      subroutine rmserror(c,cp,nlimit,mlimit,npoints,rms)

c Routine to compute solution rms error equation #73.
c Reference: Snyder, Survey Review Vol28, 217, July 1985

c C = C matrix of coefficients              input      real*8
c CP = C primed matrix of coefficients      input      real*8
c nlimit= n dimension limit                 input      integer*4
c mlimit= m dimension limit                 input      integer*4
c rms= rms error                            returned   real*8

      implicit real*8 (a-h,o-z)
      parameter (maxpts=800) ! Changes must be made in other places too !
      real*8 c(nlimit,mlimit),cp(nlimit,mlimit)
      real*8 lat(maxpts),lon(maxpts)
      real*8 costheta(maxpts),sintheta(maxpts),f(maxpts)
      common/c1/a,b,cc,lat,lon,costheta,sintheta,f

      rms=0.d0
      do i=1,npoints ! loop over random points used for fitting

c        Compute equation 67
         t=0.d0
         do m=1,mlimit
            t1=0.d0
            do n=0,nlimit-1
               t1=t1+n*c(n+1,m)*dsin(n*lat(i))
            enddo
            t=t+t1*dsin(2*m*lon(i))
         enddo
         eq67=a*(-t)

c        Compute equation 68
         t=0.d0
         do m=1,mlimit
            t1=0.d0
            do n=0,nlimit-1
               t1=t1+c(n+1,m)*dcos(n*lat(i))
            enddo
            t=t+m*t1*dcos(2*m*lon(i))
         enddo
         eq68=a*(1+2*t)

c        Compute equation 69
         t=0.d0
         do m=0,mlimit-1
            t1=0.d0
            do n=1,nlimit
               t1=t1+n*cp(n,m+1)*dcos(n*lat(i))
            enddo
            t=t+t1*dcos(2*m*lon(i))
         enddo
         eq69=a*(1.d0/dcos(lat(i))+t)

c        Compute equation 70
         t=0.d0
         do m=0,mlimit-1
            t1=0.d0
            do n=1,nlimit
               t1=t1+cp(n,m+1)*dsin(n*lat(i))
            enddo
            t=t+m*t1*dsin(2*m*lon(i))
         enddo
         eq70=a*(-2.d0*t)

         e1=eq68*sintheta(i)+eq70*costheta(i)-eq69*f(i)        !eqn 71
         e2=eq69*f(i)*sintheta(i)+eq67*f(i)*costheta(i)-eq68   !eqn 72
         rms=rms+(e1*e1+e2*e2)                                 !eqn 73

      enddo
      rms=dsqrt(rms/npoints)           ! equation 81

      return
      end

c*********************************************************************
c functions used often
      real*8 function p1(m,n,i)      ! equation 76
      implicit real*8 (a-h,o-z)
      parameter (maxpts=800) ! Changes must be made in other places too !
      real*8 lat(maxpts),lon(maxpts)
      real*8 costheta(maxpts),sintheta(maxpts),f(maxpts)
      common/c1/a,b,c,lat,lon,costheta,sintheta,f
      p1=2.d0*a*m*sintheta(i)*dcos(n*lat(i))*dcos(2.d0*m*lon(i))
      return
      end

      real*8 function p2(m,n,i)      ! equation 77
      implicit real*8 (a-h,o-z)
      parameter (maxpts=800) ! Changes must be made in other places too !
      real*8 lat(maxpts),lon(maxpts)
      real*8 costheta(maxpts),sintheta(maxpts),f(maxpts)
      common/c1/a,b,c,lat,lon,costheta,sintheta,f
      p2=-2.d0*a*m*costheta(i)*dsin(n*lat(i))*dsin(2.d0*m*lon(i))-
     +   a*n*f(i)*dcos(n*lat(i))*dcos(2.d0*m*lon(i))
      return
      end

      real*8 function p3(m,n,i)      ! equation 78
      implicit real*8 (a-h,o-z)
      parameter (maxpts=800) ! Changes must be made in other places too !
      real*8 lat(maxpts),lon(maxpts)
      real*8 costheta(maxpts),sintheta(maxpts),f(maxpts)
      common/c1/a,b,c,lat,lon,costheta,sintheta,f
      p3=-2.d0*a*m*dcos(n*lat(i))*dcos(2.d0*m*lon(i))-
     +   a*n*f(i)*dsin(n*lat(i))*dsin(2.d0*m*lon(i))*costheta(i)
      return
      end

      real*8 function p4(m,n,i)      ! equation 79
      implicit real*8 (a-h,o-z)
      parameter (maxpts=800) ! Changes must be made in other places too !
      real*8 lat(maxpts),lon(maxpts)
      real*8 costheta(maxpts),sintheta(maxpts),f(maxpts)
      common/c1/a,b,c,lat,lon,costheta,sintheta,f
      p4=a*n*f(i)*dcos(n*lat(i))*dcos(2.d0*m*lon(i))*sintheta(i)
      return
      end

c*********************************************************************
      REAL*4 FUNCTION RAN1(IDUM)
c     Returns random number between 0.0 and 1.0. To initialize provide
c     negative idum value.
      DIMENSION R(97)
      PARAMETER (M1=259200,IA1=7141,IC1=54773)
      PARAMETER (M2=134456,IA2=8121,IC2=28411)
      PARAMETER (M3=243000,IA3=4561,IC3=51349)
      PARAMETER (RM1=1./M1,RM2=1./M2)
      DATA IFF /0/
      IF (IDUM.LT.0.OR.IFF.EQ.0) THEN
        IFF=1
        IX1=MOD(IC1-IDUM,M1)
        IX1=MOD(IA1*IX1+IC1,M1)
        IX2=MOD(IX1,M2)
        IX1=MOD(IA1*IX1+IC1,M1)
        IX3=MOD(IX1,M3)
        DO 11 J=1,97
          IX1=MOD(IA1*IX1+IC1,M1)
          IX2=MOD(IA2*IX2+IC2,M2)
          R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
11      CONTINUE
        IDUM=1
      ENDIF
      IX1=MOD(IA1*IX1+IC1,M1)
      IX2=MOD(IA2*IX2+IC2,M2)
      IX3=MOD(IA3*IX3+IC3,M3)
      J=1+(97*IX3)/M3
      IF(J.GT.97) j=97
      IF(J.LT.1) j=1
      RAN1=R(J)
      R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
      RETURN
      END

C*********************************************************************
      SUBROUTINE MP_DSIMQ(A,B,N,KS)
C        PURPOSE
C           OBTAIN SOLUTION OF A SET OF SIMULTANEOUS LINEAR EQUATIONS,
C           AX=B
C
C        USAGE
C           CALL MP_DSIMQ(A,B,N,KS)
C
C        DESCRIPTION OF PARAMETERS
C           A - MATRIX OF COEFFICIENTS STORED COLUMNWISE.  THESE ARE
C               DESTROYED IN THE COMPUTATION.  THE SIZE OF MATRIX A IS
C               N BY N.
C           B - VECTOR OF ORIGINAL CONSTANTS (LENGTH N). THESE ARE
C               REPLACED BY FINAL SOLUTION VALUES, VECTOR X.
C           N - NUMBER OF EQUATIONS AND VARIABLES. N MUST BE .GT. ONE.
C           KS - OUTPUT DIGIT
C                0 FOR A NORMAL SOLUTION
C                1 FOR A SINGULAR SET OF EQUATIONS
      real*8       A(1),B(1),biga,save,tol
      character*80 msg
C
C        FORWARD SOLUTION
C
      TOL=0.d0
      KS=0
      JJ=-N
      DO 65 J=1,N
      JY=J+1
      JJ=JJ+N+1
      BIGA=0.d0
      IT=JJ-J
      DO 30 I=J,N
C
C        SEARCH FOR MAXIMUM COEFFICIENT IN COLUMN
C
      IJ=IT+I
      IF(dabs(BIGA)-dabs(A(IJ))) 20,30,30
   20 BIGA=A(IJ)
      IMAX=I
   30 CONTINUE
C
C        TEST FOR PIVOT LESS THAN TOLERANCE (SINGULAR MATRIX)
C
      IF(dabs(BIGA)-TOL) 35,35,40
   35 KS=1
      write( msg, 36 ) BIGA
   36 format( 'BIGA ',D12.6 )
      RETURN
C
C        INTERCHANGE ROWS IF NECESSARY
C
   40 I1=J+N*(J-2)
      IT=IMAX-J
      DO 50 K=J,N
      I1=I1+N
      I2=I1+IT
      SAVE=A(I1)
      A(I1)=A(I2)
      A(I2)=SAVE
C
C        DIVIDE EQUATION BY LEADING COEFFICIENT
C
   50 A(I1)=A(I1)/BIGA
      SAVE=B(IMAX)
      B(IMAX)=B(J)
      B(J)=SAVE/BIGA
C
C        ELIMINATE NEXT VARIABLE
C
      IF(J-N) 55,70,55
   55 IQS=N*(J-1)
      DO 65 IX=JY,N
      IXJ=IQS+IX
      IT=J-IX
      DO 60 JX=JY,N
      IXJX=N*(JX-1)+IX
      JJX=IXJX+IT
   60 A(IXJX)=A(IXJX)-(A(IXJ)*A(JJX))
   65 B(IX)=B(IX)-(B(J)*A(IXJ))
C
C        BACK SOLUTION
C
   70 NY=N-1
      IT=N*N
      DO 80 J=1,NY
      IA=IT-J
      IB=N-J
      IC=N
      DO 80 K=1,J
      B(IB)=B(IB)-A(IA)*B(IC)
      IA=IA-N
   80 IC=IC-1
      RETURN
      END

c ***********************************************************************
      subroutine authalic_coef(a,b,c,mlimit,klimit,nlimit,
     +        areafun,autlon,acoef,coef,coefp,radsph)

c To compute coefficients permitting the snyder to authalic computation.
c a= major axis normalized to 1              real*8  input
c b= middle axis normalized                  real*8 input
c c= minor axis normalized                   real*8 input
c mlimit= m maximum                          integer*4 input
c klimit= k maximum                          integer*4 input
c nlimit= n maximum                          integer*4 input
c arefun= scratch space for buffer areafun   real*8    input
c autlon= scratch space for buffer autlon    real*8    input
c acoef= scratch space for buffer acoef      real*8    input
c coef= longitude computation coefficients   real*8  returned
c coefp= latitude computation coefficients   real*8 returned
c radsph= radius of equivalent sphere        real*8 returned

      implicit real*8 (a-h,o-z)
      parameter (latpts=72,lonpts=72)
      real*8 elllat(0:latpts),elllon(0:lonpts)
      real*8 areafun(0:latpts,0:lonpts)
      real*8 acoef(0:latpts,0:mlimit),autlat(0:latpts)
      real*8 autlon(0:latpts,0:lonpts)
      real*8 coef(0:mlimit,0:klimit),coefp(nlimit)

      do i=0,latpts
	do j=0,mlimit
	   acoef(i,j)=0.0
	enddo
      enddo
      do i=0,latpts
	do j=0,lonpts
	   autlon(i,j)=0.0
	enddo
      enddo
      do i=0,mlimit
	do j=0,klimit
	   coef(i,j)=0.0
	enddo
      enddo
      do i=0,latpts
	autlat(i)=0.0
      enddo
      do i=1,nlimit
	coefp(i)=0.0
      enddo

      dg1=datan(1.d0)/45.d0
      pi=datan(1.d0)*4.d0
      pih=pi/2.d0
      cb2=c*c/(b*b)
      ba2=b*b

      do i=0,latpts-1
        elllat(i)=i*dg1*90.d0/latpts
      enddo
      elllat(latpts)=(latpts-.001)*dg1*90.d0/latpts
      do j=0,lonpts
        elllon(j)=j*dg1*90.d0/lonpts
      enddo

c compute area function for integration
      do i=0,latpts
        do j=0,lonpts
          slon=dsin(elllon(j))
          clon=dcos(elllon(j))
          slat=dsin(elllat(i))
          clat=dcos(elllat(i))
          flon=slon*slon+ba2*clon*clon       ! eqn 9
          flat=slat*slat+cb2*clat*clat       ! eqn 10
          t1=(1.d0-ba2)*slon*clon*slat
          t2=dsqrt(slat*slat+cb2*cb2*flon*clat*clat)
          t3=dsqrt(slon*slon+ba2*ba2*clon*clon)
	  costheta=t1/(t2*t3)                ! eqn 48
          sintheta=dsqrt(dabs(1.d0-costheta*costheta))
          areafun(i,j)=clat*t3*t2*sintheta/(flon*flon*flat*flat)
        enddo
      enddo

c compute total area of triaxial ellipsoid
      latlmt=latpts
      call simp2(lonlmt,lonpts,fsimlon,latlmt,c,latpts,
     +           elllat,areafun,pih,area)
      tarea=area

c compute authalic latitudes
      latlmt=0
      autlat(0)=0.d0
      do latlmt=6,latpts,6
        call simp2(lonlmt,lonpts,fsimlon,latlmt,c,latpts,
     +             elllat,areafun,pih,area)
        sphiaut=area/tarea
        if(dabs(sphiaut).gt. 0.9999999)then
          autlat(latlmt)=pih
        else
          autlat(latlmt)=
     +        datan(sphiaut/dsqrt(dabs(1.d0-sphiaut*sphiaut)))
        endif
      enddo

c compute coefficients for authalic latitude using simpson integration
      do n=1,nlimit
        sum1=0.d0
        do i=6,latpts-6,12
          autfunc=(autlat(i)-elllat(i))*dsin(2*n*elllat(i))
          sum1=sum1+4.d0*autfunc
        enddo
        do i=12,latpts-12,12
          autfunc=(autlat(i)-elllat(i))*dsin(2*n*elllat(i))
          sum1=sum1+2.d0*autfunc
        enddo
        coefp(n)=4.d0*sum1/latpts
      enddo
      radsph=a*dsqrt(8.d0*tarea/(4.d0*pi)) !radius of equivalent sphere

c compute authalic longitude
      do i=0,latpts,6
c       first compute area of zone of quadrant along latitude
        lonlmt=lonpts
        call simp1(latpts,lonpts,areafun,i,lonlmt,pih,fsimlon)
        tcirc=fsimlon
c       now compute portion of zone for each step of longitude
        lonlmt=0
        autlon(i,0)=0.d0
        do lonlmt=6,lonpts,6
          call simp1(latpts,lonpts,areafun,i,lonlmt,pih,fsimlon)
          autlon(i,lonlmt)=(fsimlon/tcirc)*pih
        enddo
      enddo

c compute elements for simpson integration for acoef of authalic longitude
      do m=0,mlimit
        do i=0,latpts,6
          sum1=0.d0
          do j=6,lonpts-6,12
            autfunc=(autlon(i,j)-elllon(j))*dsin(2*m*elllon(j))
            sum1=sum1+4.d0*autfunc
          enddo
          do j=12,lonpts-12,12
            autfunc=(autlon(i,j)-elllon(j))*dsin(2*m*elllon(j))
            sum1=sum1+2.d0*autfunc
          enddo
          acoef(i,m)=4.d0*sum1/lonpts
        enddo
      enddo

c compute elements for simpson integration for C coef of authalic longitude
      do m=0,mlimit
        k=0
        sum1=acoef(0,m)
        do j=6,latpts-6,12
          sum1=sum1+4.d0*acoef(j,m)
        enddo
        do j=12,latpts-12,12
          sum1=sum1+2.d0*acoef(j,m)
        enddo
        sum1=sum1+acoef(latpts,m)
        coef(m,0)=2.d0*sum1/latpts
c	write(msg,800)(coef(m,0))
c 800	format(5f16.11)
      enddo

      do m=1,mlimit
        do k=1,klimit
          sum1=acoef(0,m)
          do j=6,latpts-6,12
            autfunc=acoef(j,m)*dcos(2*k*elllat(j))
            sum1=sum1+4.d0*autfunc
          enddo
          do j=12,latpts-12,12
            autfunc=acoef(j,m)*dcos(2*k*elllat(j))
            sum1=sum1+2.d0*autfunc
          enddo
          sum1=sum1+acoef(latpts,m)*dcos(2*k*elllat(latpts))
          coef(m,k)=4.d0*sum1/latpts
c	  write(msg,801)(coef(m,k))
c 801	  format(5f16.11)
        enddo
      enddo

      return
      end

c *********************************************************************
      subroutine simp1(latpts,lonpts,areafun,i,lonlmt,pih,fsimlon)

c Compute elements for Simpsons integration.
c fsimlon is returned
      implicit real*8 (a-h,o-z)
      real*8 areafun(0:latpts,0:lonpts)

      sum1=areafun(i,0)+areafun(i,lonlmt)
      do j=1,lonlmt-1,2
         sum1=sum1+4.d0*areafun(i,j)
      enddo
      do j=2,lonlmt-2,2
         sum1=sum1+2.d0*areafun(i,j)
      enddo
      fsimlon=sum1*pih/(lonpts*3)
      return
      end

c ******************************************************************
      subroutine simp2(lonlmt,lonpts,fsimlon,latlmt,c,latpts,
     +                  elllat,areafun,pih,area)

c Computes areas of zones
c lonlmt & area are returned
      implicit real*8 (a-h,o-z)

      real*8 elllat(0:latpts)
      real*8 areafun(0:latpts,0:lonpts)

      i=0
      lonlmt=lonpts
      call simp1(latpts,lonpts,areafun,i,lonlmt,pih,fsimlon)
      sum2=fsimlon
      do i=1,latlmt-1,2
         call simp1(latpts,lonpts,areafun,i,lonlmt,pih,fsimlon)
         sum2=sum2+4.d0*fsimlon
      enddo
      do i=2,latlmt-2,2
         call simp1(latpts,lonpts,areafun,i,lonlmt,pih,fsimlon)
         sum2=sum2+2.d0*fsimlon
      enddo
      i=latlmt
      call simp1(latpts,lonpts,areafun,i,lonlmt,pih,fsimlon)
      sum2=sum2+fsimlon

      area=c*c*sum2*elllat(latlmt)/(latlmt*3)
      return
      end

c********************************************************************
      subroutine authalic_rmserror(coef,coefp,nlimit,klimit,mlimit,
     +     radsph,degtorad,a,b,c,rmse)

c Routine to compute authalic solution rms error equation.
c Reference: Snyder, Survey Review Vol28, 217, July 1985

c COEF =  matrix of coefficients              input      real*8
c COEFP = primed matrix of coefficients      input      real*8
c nlimit= n dimension limit                 input      integer*4
c klimit= k dimension limit                 input      integer*4
c mlimit= m dimension limit                 input      integer*4
c radsph= radius of equivalent sphere       input      real*8
c degtorad=degrees/radian                   input      real*8
c a= major ellipsoid radius                 input      real*8
c b= middle ellipsoid radius                 input      real*8
c c= small ellipsoid radius                 input      real*8
c rms= rms error                            returned   real*8

      implicit real*8 (a-h,o-z)
      real*8 coef(0:mlimit,0:klimit),coefp(nlimit)

      bige=0.d0
      lptcount=0
      cb2=c*c/(b*b)
      ba2=b*b
      pi=datan(1.d0)*4.d0
      pih=pi/2.d0

      do i=0,90,5
        do j=90,0,-5
          elat=j
          elon=i
          call authtran(coef,coefp,nlimit,klimit,mlimit,
     +          elat,elon,alat,alon,1,ind)
          elat=elat*degtorad
          elon=elon*degtorad
          alat=alat*degtorad
          alon=alon*degtorad
          sp=dsin(elat)
          cp=dcos(elat)
          sl=dsin(elon)
          cl=dcos(elon)
          f1p=sp*sp+cb2*cp*cp
          f1l=sl*sl+ba2*cl*cl
          f2p=dsqrt(sp*sp+f1l*cb2*cb2*cp*cp)
          f2l=dsqrt(sl*sl+ba2*ba2*cl*cl)
          dxdp=0.d0
          dydp=1.d0
          dxdl=1.d0
          dydl=0.d0
          do m=1,mlimit
            dxdll=0.d0
            dxdpl=0.d0
            do k=0,klimit
              dxdll=dxdll+coef(m,k)*dcos(2*k*elat)
              dxdpl=dxdpl+2*k*coef(m,k)*dsin(2*k*elat)
            enddo
            dxdl=dxdl+dxdll*2.d0*m*dcos(2*m*elon)
            dxdp=dxdp-dxdpl*dsin(2*m*elon)
          enddo
          do n=1,nlimit
            dydp=dydp+n*2*coefp(n)*dcos(2*n*elat)
          enddo
          dxdl=dxdl*radsph/a
          dxdp=dxdp*radsph/a
          dydp=(dydp*radsph/a)*dcos(alat)
          dsdp=c*f2p/(dsqrt(f1l)*f1p*dsqrt(f1p))
          dsdl=c*cp*f2l/(dsqrt(f1p)*f1l*dsqrt(f1l))
          sinth=dydp/dsqrt(dxdp*dxdp+dydp*dydp)
          sh=dsqrt(dxdp*dxdp+dydp*dydp)/dsdp  ! scale factr on meridian
          sk=dxdl/dsdl                        ! scale factr on parallel
          th=(pih-datan(dxdp/dydp))/degtorad
          arerr=sh*sk*sinth-1.d0
          if(j.lt.89) then
            bige=bige+arerr*arerr
            lptcount=lptcount+1
          endif
        enddo    ! j
      enddo      ! i
      rmse=dsqrt(bige/lptcount)

      return
      end

c ***************************************************************


	FUNCTION PR_TPFR  ( tmin, tmax, pp24 )
C************************************************************************
C* PR_TPFR								*
C*									*
C* This function computes TPFR.						*
C*									*
C* REAL PR_TPFR  ( TMIN, TMAX, PP24 )                                   *
C*									*
C* Input parameters:							*
C*	TMIN		REAL		Minimum temperature		*
C*	TMAX		REAL		Maximum temperature		*
C*	PP24 		REAL		Probability of precipitation	*
C*									*
C* Output parameters:							*
C*	PR_TPFR		REAL		Coded value for Min/Max/POP	*
C**									*
C* Log:									*
C* S. Jacobs/NCEP	 3/99						*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
C*
	EQUIVALENCE	( ival, rval )
C*
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
	ival = 0
C
C*	Construct the coded integer. The value is 9 digits as in
C*	PPPXXXNNN. Where PPP is the POP, XXX is the Max temp and
C*	NNN is the Min temp. All values are adjusted by 200 to
C*	account for negative and missing values.
C
	IF  ( .not. ERMISS ( tmin ) )  THEN
	    ival = ival + ( NINT(tmin) + 200 )
	END IF
C
	IF  ( .not. ERMISS ( tmax ) )  THEN
	    ival = ival + ( NINT(tmax) + 200 ) * 1000
	END IF
C
	IF  ( .not. ERMISS ( pp24 ) )  THEN
	    ival = ival + ( NINT(pp24) + 200 ) * 1000000
	END IF
C
C*	If all three values are missing, then the answer is missing.
C*	Otherwise, set the output to the REAL number equivalent of
C*	the coded integer.
C
	IF  ( ival .eq. 0 )  THEN
	    PR_TPFR = RMISSD
	  ELSE
	    PR_TPFR = rval
	END IF
C*
	RETURN
	END


SUBROUTINE smooth_polar(ncep_in, ncep_out, nlonp, nlatp)
IMPLICIT NONE
INTEGER, INTENT(IN)                          :: nlonp, nlatp
REAL, DIMENSION(nlonp,nlatp), INTENT(INOUT)  :: ncep_in, ncep_out
REAL sum
INTEGER i,i_lat,latb1,latb2,latt1,latt2

latb1 = 2
latb2 = 10
latt1 = nlatp-9
latt2 = nlatp-1

ncep_out = ncep_in

DO i_lat=latb1,latb2
  ncep_out(2:nlonp-1,i_lat) = 0.25*ncep_in(1:nlonp-2,i_lat)+0.5*ncep_in(2:nlonp-1,i_lat) &
                               +0.25*ncep_in(3:nlonp,i_lat)
  ncep_out(1,i_lat) = 0.25*ncep_in(nlonp-1,i_lat)+0.5*ncep_in(1,i_lat)+0.25*ncep_in(2,i_lat)
  ncep_out(nlonp,i_lat) = ncep_out(1,i_lat)
ENDDO

DO i_lat=latt1,latt2
  ncep_out(2:nlonp-1,i_lat) = 0.25*ncep_in(1:nlonp-2,i_lat)+0.5*ncep_in(2:nlonp-1,i_lat) &
                               +0.25*ncep_in(3:nlonp,i_lat)
  ncep_out(1,i_lat) = 0.25*ncep_in(nlonp-1,i_lat)+0.5*ncep_in(1,i_lat)+0.25*ncep_in(2,i_lat)
  ncep_out(nlonp,i_lat) = ncep_out(1,i_lat)
ENDDO

ncep_in = ncep_out

DO i_lat=latb1,latb2
  ncep_out(2:nlonp-1,i_lat) = 0.25*ncep_in(1:nlonp-2,i_lat)+0.5*ncep_in(2:nlonp-1,i_lat) &
                               +0.25*ncep_in(3:nlonp,i_lat)
  ncep_out(1,i_lat) = 0.25*ncep_in(nlonp-1,i_lat)+0.5*ncep_in(1,i_lat)+0.25*ncep_in(2,i_lat)
  ncep_out(nlonp,i_lat) = ncep_out(1,i_lat)
ENDDO

DO i_lat=latt1,latt2
  ncep_out(2:nlonp-1,i_lat) = 0.25*ncep_in(1:nlonp-2,i_lat)+0.5*ncep_in(2:nlonp-1,i_lat) &
                               +0.25*ncep_in(3:nlonp,i_lat)
  ncep_out(1,i_lat) = 0.25*ncep_in(nlonp-1,i_lat)+0.5*ncep_in(1,i_lat)+0.25*ncep_in(2,i_lat)
  ncep_out(nlonp,i_lat) = ncep_out(1,i_lat)
ENDDO

! Smooth boundary between zonally smoothed and unsmoothed data
ncep_out(:,latb2) = 0.25*ncep_out(:,latb2-1)+0.5*ncep_out(:,latb2)+0.25*ncep_out(:,latb2+1)

ncep_out(:,latt1) = 0.25*ncep_out(:,latt1-1)+0.5*ncep_out(:,latt1)+0.25*ncep_out(:,latt1+1)

! Smooth around the North Pole

sum = 0.
DO i=2,nlonp-1
   sum = sum + ncep_out(i,nlatp-1)
ENDDO
sum = sum/REAL(nlonp-2)
DO i=1,nlonp
   ncep_out(i,nlatp) = sum
ENDDO

END SUBROUTINE smooth_polar


module gputils

    use array_utils
    use random, only: setgmnd, genmnd
    implicit none

    real(kind=8), parameter, private :: pi = 3.1415926535897932384626433832795029d0
    real(kind=8), parameter, private :: const1 = 0.9189385332046727417803297364056176398d0 ! 0.5*ln(2*pi)

    ! base type for Gaussian Process kernels
    type Kernel
        real(kind=8), dimension(:), allocatable :: pars
    contains
        !procedure(evaluate_kernel), pointer :: get_matrix_pointer => NULL()
        procedure :: evaluate_kernel
        procedure :: sample_prior
        procedure :: set_kernel_pars, get_kernel_pars
        !procedure :: add_kernel_to_kernel
        !generic :: operator(+) => add_kernel_to_kernel
    end type Kernel

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!! Implemented kernels follow !!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! This kernel returns a constant over the whole covariance matrix
    type, extends(Kernel) :: ConstantKernel
    contains
        procedure :: evaluate_kernel => evaluate_kernel_ConstantKernel
    end type ConstantKernel

    ! This kernel returns a constant along the diagonal: "white noise" (homoskedastic)
    type, extends(Kernel) :: DiagonalKernel
    contains
        procedure :: evaluate_kernel => evaluate_kernel_DiagonalKernel
    end type DiagonalKernel

    ! This is a "white noise" (heteroskedastic) kernel
    type, extends(Kernel) :: WhiteKernel
    contains
        procedure :: evaluate_kernel => evaluate_kernel_WhiteKernel
    end type WhiteKernel

    ! Exponential kernel
    type, extends(Kernel) :: ExpKernel
    contains
        procedure :: evaluate_kernel => evaluate_kernel_ExpKernel
    end type ExpKernel

    ! Exponential squared kernel
    type, extends(Kernel) :: ExpSquaredKernel
    contains
        procedure :: evaluate_kernel => evaluate_kernel_ExpSquaredKernel
    end type ExpSquaredKernel

    ! Exponential sine squared kernel
    type, extends(Kernel) :: ExpSineSquaredKernel
    contains
        procedure :: evaluate_kernel => evaluate_kernel_ExpSineSquaredKernel
    end type ExpSineSquaredKernel

    ! Sum of kernels
    ! this is a hack to substitute operator overloading (which I can't do...)
    ! it should be pretty slow
    type, extends(Kernel) :: SumKernels
        ! nullify to prevent from needing initialization
        class(Kernel), pointer :: kernel1 => NULL()
        class(Kernel), pointer :: kernel2 => NULL()
        class(Kernel), pointer :: kernel3 => NULL()
        !class(Kernel), pointer :: kernel4 => NULL()
        !class(Kernel), pointer :: kernel5 => NULL()
    contains
        procedure :: evaluate_kernel => evaluate_kernel_sum
        procedure :: set_kernel_pars => set_sub_kernel_pars_sum
        procedure :: get_kernel_pars => get_sub_kernel_pars_sum
    end type SumKernels

    ! Product of kernels
    type, extends(Kernel) :: ProductKernels
        ! nullify to prevent from needing initialization
        class(Kernel), pointer :: kernel1 => NULL()
        class(Kernel), pointer :: kernel2 => NULL()
        class(Kernel), pointer :: kernel3 => NULL()
    contains
        procedure :: evaluate_kernel => evaluate_kernel_product
        procedure :: set_kernel_pars => set_sub_kernel_pars_prod
        procedure :: get_kernel_pars => get_sub_kernel_pars_prod
    end type ProductKernels

    ! user-defined constructor for the Kernel type
    interface Kernel
        module procedure new_Kernel
    end interface

    ! generic interface for kernel addition subroutines (up to 3 kernels for now)
    interface evaluate_kernel_sum_kernels
        procedure evaluate_kernel_sum_2_kernels
        procedure evaluate_kernel_sum_3_kernels
    end interface

    ! generic interface for kernel multiplication subroutines (up to 3 kernels for now)
    interface evaluate_kernel_product_kernels
        procedure evaluate_kernel_product_2_kernels
        procedure evaluate_kernel_product_3_kernels
    end interface

    ! base type for a Gaussian Process
    type GP
        ! the mean function associated with this GP
        procedure(mean_fun_template), pointer, nopass :: mean_fun => NULL()
        ! the covariance function associated with this GP
        real(kind=8), dimension(:, :), allocatable :: cov
        ! the kernel associated with this GP
        class(Kernel), pointer :: gp_kernel
        ! possible sub-kernels (we only allow one level down for now)
        class(Kernel), pointer :: sub_kernel1
        class(Kernel), pointer :: sub_kernel2
    contains
        procedure :: is_posdef
        procedure :: get_lnlikelihood
        procedure :: predict
        procedure :: sample_conditional
    end type GP

    ! user-defined constructor for the GP type
    interface GP
        module procedure new_GP
    end interface

contains

    function new_Kernel(parameters)
        ! this is the Kernel derived-type constructor
        real(kind=8), dimension(:), intent(in) :: parameters
        type(Kernel) new_Kernel
        integer :: size_pars

        size_pars = size(parameters)

        allocate(new_Kernel%pars(size_pars))
        new_Kernel%pars = parameters

    end function new_Kernel

<<<<<<< HEAD
    function new_GP(cov_matrix, kernel_ptr, subkernel_ptr1, subkernel_ptr2)
        ! this is the GP derived-type constructor
        real(kind=8), dimension(:, :) :: cov_matrix
        class(Kernel), pointer :: kernel_ptr
        class(Kernel), pointer, optional :: subkernel_ptr1, subkernel_ptr2
        type(GP) new_GP
        integer :: shape_cov(2), N

        shape_cov = shape(cov_matrix)
        if (shape_cov(1) /= shape_cov(2)) STOP 'covariance matrix must be square'
        N = shape_cov(1)

        allocate(new_GP%cov(N, N))
        new_GP%cov = cov_matrix
        new_GP%gp_kernel => kernel_ptr

        if(present(subkernel_ptr1)) new_GP%sub_kernel1 => subkernel_ptr1
        if(present(subkernel_ptr2)) new_GP%sub_kernel2 => subkernel_ptr2

    end function new_GP

    function evaluate_kernel(self, x1, x2) result(matrix)
        ! dummy method: subclasses should implement this themselves
        class(Kernel), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1),size(x2)) :: matrix
        STOP 'Not implemented by parent class'
    end function evaluate_kernel

    function evaluate_kernel_ConstantKernel(self, x1, x2) result(matrix)
        ! Value of the kernel evaluated at a given pair of coordinates x1, x2
        class(ConstantKernel), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix

        if (size(self%pars) /= 1) STOP 'Wrong parameter dimension - ConstantKernel(1 hyper)'
        call fill_matrix_with_value(matrix, self%pars(1)**2)
    end function evaluate_kernel_ConstantKernel

    function evaluate_kernel_DiagonalKernel(self, x1, x2) result(matrix)
        ! Value of the kernel evaluated at a given pair of coordinates x1, x2
        class(DiagonalKernel), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix

        if (size(self%pars) /= 1) STOP 'Wrong parameter dimension - DiagonalKernel(1 hyper)'
        ! pars(1) --> amplitude
        matrix = 0.d0
        call add_value_to_diagonal(matrix, self%pars(1))

    end function evaluate_kernel_DiagonalKernel

    function evaluate_kernel_WhiteKernel(self, x1, x2) result(matrix)
        ! Value of the kernel evaluated at a given pair of coordinates x1, x2
        class(WhiteKernel), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix

        if (size(self%pars) /= size(x1)) STOP 'Wrong parameter dimension - WhiteKernel(diag array)'
        ! pars(:) --> uncertainties on the data points, added in quadrature to the diagonal of the covariance matrix
        matrix = 0.d0
        call add_array_to_diagonal(matrix, self%pars**2)

    end function evaluate_kernel_WhiteKernel

    function evaluate_kernel_ExpKernel(self, x1, x2) result(matrix)
        ! Value of the kernel evaluated at a given pair of coordinates x1, x2
        class(ExpKernel), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix

        !if (size(self%pars) /= 1) STOP 'Wrong parameter dimension'
        matrix = 0.d0
        matrix = get_radial_coordinates(x1, x2)
        matrix = exp(-abs(matrix))

    end function evaluate_kernel_ExpKernel

    function evaluate_kernel_ExpSquaredKernel(self, x1, x2) result(matrix)
        ! Value of the kernel evaluated at a given pair of coordinates x1, x2
        class(ExpSquaredKernel), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix

        if (size(self%pars) /= 1) STOP 'Wrong parameter dimension - ExpSquaredKernel(1 hyper)'
        ! pars(1) --> lengthscale
        matrix = 0.d0
        matrix = get_radial_coordinates(x1, x2)
        matrix = exp(-0.5d0 * (matrix / self%pars(1))**2)

    end function evaluate_kernel_ExpSquaredKernel

    function evaluate_kernel_ExpSineSquaredKernel(self, x1, x2) result(matrix)
        ! Value of the kernel evaluated at a given pair of coordinates x1, x2
        class(ExpSineSquaredKernel), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix
        real(kind=8) :: gamma, omega

        if (size(self%pars) /= 2) STOP 'Wrong parameter dimension - ExpSineSquaredKernel(2 hyper)'
        ! pars(1) --> period
        ! pars(2) --> correlation scale
        omega = pi / self%pars(1)
        gamma = 2.d0 / self%pars(2)**2

        matrix = 0.d0
        !call add_value_to_diagonal(matrix, 1.d0)
        matrix = get_radial_coordinates(x1, x2)
        matrix = exp( -gamma * sin( omega * abs(matrix) )**2 )

    end function evaluate_kernel_ExpSineSquaredKernel

    function evaluate_kernel_sum_2_kernels(k1, k2, x1, x2, a1, a2) result(matrix)
        ! Return the sum of covariance matrices for k1 and k2 at given independent coordinates
        class(Kernel), intent(in) :: k1, k2
        real(kind=8), intent(in), optional :: a1, a2
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix
        real(kind=8) aa1, aa2

        aa1 = 1.d0
        aa2 = 1.d0
        if (present(a1)) aa1 = a1
        if (present(a2)) aa2 = a2
        matrix = aa1 * k1%evaluate_kernel(x1, x2) + aa2 * k2%evaluate_kernel(x1, x2)
        !print *, 'kernel evaluated'

    end function evaluate_kernel_sum_2_kernels

    function evaluate_kernel_sum_3_kernels(k1, k2, k3, x1, x2, a1, a2, a3) result(matrix)
        ! Return the sum of covariance matrices for k1, k2 and k3 at given independent coordinates
        class(Kernel), intent(in) :: k1, k2, k3
        real(kind=8), intent(in), optional :: a1, a2, a3
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix
        real(kind=8) aa1, aa2, aa3

        aa1 = 1.d0
        aa2 = 1.d0
        aa3 = 1.d0
        if (present(a1)) aa1 = a1
        if (present(a2)) aa2 = a2
        if (present(a3)) aa3 = a3

        matrix = aa1 * k1%evaluate_kernel(x1, x2) + aa2 * k2%evaluate_kernel(x1, x2) + aa3 * k3%evaluate_kernel(x1, x2)

    end function evaluate_kernel_sum_3_kernels

    function evaluate_kernel_product_2_kernels(k1, k2, x1, x2, a1, a2) result(matrix)
        ! Return the product of covariance matrices for k1 and k2 at given independent coordinates
        class(Kernel), intent(in) :: k1, k2
        real(kind=8), intent(in), optional :: a1, a2
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix
        real(kind=8) aa1, aa2

        aa1 = 1.d0
        aa2 = 1.d0
        if (present(a1)) aa1 = a1
        if (present(a2)) aa2 = a2

        matrix = aa1 * k1%evaluate_kernel(x1, x2) * aa2 * k2%evaluate_kernel(x1, x2)

    end function evaluate_kernel_product_2_kernels

    function evaluate_kernel_product_3_kernels(k1, k2, k3, x1, x2, a1, a2, a3) result(matrix)
        ! Return the product of covariance matrices for k1, k2 and k3 at given independent coordinates
        class(Kernel), intent(in) :: k1, k2, k3
        real(kind=8), intent(in), optional :: a1, a2, a3
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix
        real(kind=8) aa1, aa2, aa3

        aa1 = 1.d0
        aa2 = 1.d0
        aa3 = 1.d0
        if (present(a1)) aa1 = a1
        if (present(a2)) aa2 = a2
        if (present(a3)) aa3 = a3

        matrix = aa1 * k1%evaluate_kernel(x1, x2) * aa2 * k2%evaluate_kernel(x1, x2) * aa3 * k3%evaluate_kernel(x1, x2)

    end function evaluate_kernel_product_3_kernels

    function evaluate_kernel_sum(self, x1, x2) result(matrix)
        ! Return the sum of covariance matrices for self's associated kernels at given independent coordinates
        class(SumKernels), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix
        real(kind=8) :: aa1, aa2, aa3

        if (.not. associated(self%kernel1)) STOP 'kernel1 is not associated'

        if (associated(self%kernel1) .and. associated(self%kernel2) .and. associated(self%kernel3)) then
            ! three kernels are associated
            if (size(self%pars) /= 3) STOP 'Need 3 multiplying constants for 3 associated kernels'
            aa1 = self%pars(1)
            aa2 = self%pars(2)
            aa3 = self%pars(3)
            matrix = evaluate_kernel_sum_3_kernels(self%kernel1, self%kernel2, self%kernel3, x1, x2, a1=aa1, a2=aa2, a3=aa3)

        else if (associated(self%kernel1) .and. associated(self%kernel2)) then
            ! only two kernels are associated
            if (size(self%pars) /= 2) STOP 'Need 2 multiplying constants for 2 associated kernels'
            aa1 = self%pars(1)
            aa2 = self%pars(2)
            matrix = evaluate_kernel_sum_2_kernels(self%kernel1, self%kernel2, x1, x2, a1=aa1, a2=aa2)
        end if

    end function evaluate_kernel_sum

    function evaluate_kernel_product(self, x1, x2) result(matrix)
        ! Return the product of covariance matrices for self's associated kernels at given independent coordinates
        class(ProductKernels), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: matrix
        real(kind=8) :: aa1, aa2, aa3

        if (.not. associated(self%kernel1)) STOP 'kernel1 is not associated'

        if (associated(self%kernel1) .and. associated(self%kernel2) .and. associated(self%kernel3)) then
            ! three kernels are associated
            if (size(self%pars) /= 3) STOP 'Need 3 multiplying constants for 3 associated kernels'
            aa1 = self%pars(1)
            aa2 = self%pars(2)
            aa3 = self%pars(3)
            matrix = evaluate_kernel_product_3_kernels(self%kernel1, self%kernel2, self%kernel3, x1, x2, a1=aa1, a2=aa2, a3=aa3)

        else if (associated(self%kernel1) .and. associated(self%kernel2)) then
            ! only two kernels are associated
            if (size(self%pars) /= 2) STOP 'Need 2 multiplying constants for 2 associated kernels'
            aa1 = self%pars(1)
            aa2 = self%pars(2)
            matrix = evaluate_kernel_product_2_kernels(self%kernel1, self%kernel2, x1, x2, a1=aa1, a2=aa2)
        end if

    end function evaluate_kernel_product

    subroutine set_kernel_pars(self, k, p)
        ! dummy method: subclasses should implement this themselves
        class(Kernel), intent(inout) :: self
        integer, intent(in) :: k
        real(kind=8), dimension(:), intent(in) :: p
    end subroutine set_kernel_pars

    subroutine set_sub_kernel_pars_sum(self, k, p)
        class(SumKernels), intent(inout) :: self
        integer, intent(in) :: k
        real(kind=8), dimension(:), intent(in) :: p

        if (.not. associated(self%kernel1)) STOP 'set_sub_kernel_pars_sum : kernel1 is not associated'
        if (k == 1) then
            !print *, self%kernel1%pars
            self%kernel1%pars = p
            !print *, self%kernel1%pars
            return
        end if

        if (.not. associated(self%kernel2)) STOP 'set_sub_kernel_pars_sum : kernel2 is not associated'
        if (k == 2) then
            !print *, self%kernel2%pars
            self%kernel2%pars = p
            !print *, self%kernel2%pars
            return
        end if
    end subroutine set_sub_kernel_pars_sum

    subroutine set_sub_kernel_pars_prod(self, k, p)
        class(ProductKernels), intent(inout) :: self
        integer, intent(in) :: k
        real(kind=8), dimension(:), intent(in) :: p

        if (.not. associated(self%kernel1)) STOP 'set_sub_kernel_pars_prod : kernel1 is not associated'
        if (k == 1) then
            !print *, self%kernel1%pars
            self%kernel1%pars = p
            !print *, self%kernel1%pars
            return
        end if

        if (.not. associated(self%kernel2)) STOP 'set_sub_kernel_pars_prod : kernel2 is not associated'
        if (k == 2) then
            !print *, self%kernel2%pars
            self%kernel2%pars = p
            !print *, self%kernel2%pars
            return
        end if
    end subroutine set_sub_kernel_pars_prod

    subroutine get_kernel_pars(self, k)
        ! dummy method: subclasses should implement this themselves
        class(Kernel), intent(inout) :: self
        integer, intent(in) :: k
    end subroutine get_kernel_pars

    subroutine get_sub_kernel_pars_sum(self, k)
        ! dummy method: subclasses should implement this themselves
        class(SumKernels), intent(inout) :: self
        integer, intent(in) :: k
        if (k==1) print *, self%kernel1%pars
        if (k==2) print *, self%kernel2%pars
    end subroutine get_sub_kernel_pars_sum

    subroutine get_sub_kernel_pars_prod(self, k)
        ! dummy method: subclasses should implement this themselves
        class(ProductKernels), intent(inout) :: self
        integer, intent(in) :: k
        if (k==1) print *, self%kernel1%pars
        if (k==2) print *, self%kernel2%pars
    end subroutine get_sub_kernel_pars_prod

    function sample_prior(self, t) result(sample)
        ! draw samples from the prior at coordinates t
        class(Kernel), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: t
        real(kind=8), dimension(size(t)) :: sample

        real(kind=8), dimension(size(t), size(t)) :: cov
        real(kind=8), dimension(size(t)) :: mean

        cov = self%evaluate_kernel(t, t)
        sample = multivariate_normal_sample(mean, cov)

    end function sample_prior

    function mean_fun_template(x, args) result(mean)
        ! dummy method: subclasses should implement this themselves
        ! by assigning a suitable function to GP%mean_fun
        real(kind=8), dimension(:), intent(in) :: x, args
        real(kind=8), dimension(size(x)) :: mean
    end function mean_fun_template

    function mean_fun_constant(x, args) result(mean)
        ! Constant value mean function - returns args(1)
        real(kind=8), dimension(:), intent(in) :: x, args
        real(kind=8), dimension(size(x)) :: mean

        mean = args(1)
    end function mean_fun_constant

    function is_posdef(self) result(is)
        class(GP), intent(in) :: self
        logical :: is
        real(kind=8), dimension(:, :), allocatable :: cov_cho_factor
        real(kind=8), dimension(:), allocatable :: yy, xsol
        integer :: N, rc

        N = minval(shape(self%cov))
        allocate(yy(N), xsol(N))
        allocate(cov_cho_factor(N,N))
        cov_cho_factor = self%cov

        call choly(1, N, cov_cho_factor, yy, xsol, rc)
        is = .true.
        if (rc == 2) is = .false.

    end function is_posdef

    function get_lnlikelihood(self, x, y, args, yerr) result(lnlike)
        ! Compute the log likelihood of a set of observations x,y under this GP
        ! args is passed directly to GP%mean_fun
        class(GP), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x, y, args
        real(kind=8), dimension(:), intent(in), optional :: yerr
        real(kind=8) :: lnlike
        real(kind=8), dimension(size(y), size(y)) :: cov_cho_factor
        real(kind=8), dimension(size(y)) :: yy, xsol
        real(kind=8), dimension(size(y), 1) :: yy_m  ! 2-dimensional array to go into DPOTRF, DPOTRS
        integer :: N, rc
        !real(kind=8) :: time1, time2

        if (size(x) /= size(y)) STOP 'Dimension mismatch in get_lnlikelihood'
        if (.not. associated(self%mean_fun)) STOP 'GP%mean_fun is not associated'

        N = size(y)
!         call cpu_time(time1)
        cov_cho_factor = self%gp_kernel%evaluate_kernel(x, x)
!         call cpu_time(time2)
!         print *, 'Took ', time2-time1

        ! optionally add data uncertainties in quadrature to covariance matrix
        if (present(yerr)) then
            if (size(yerr) /= N) STOP 'Dimension mismatch in get_lnlikelihood'
            call add_array_to_diagonal(cov_cho_factor, yerr**2)
        end if

        ! solve the linear system using the cholesky method
        if (size(args) == 1 .and. args(1) == 0.d0) then
            yy = y ! skip calling the mean function if it's zero
        else
            yy = y - self%mean_fun(x, args)  ! rh
        end if
        yy_m(:, 1) = yy

!         call cpu_time(time1)
        call DPOTRF( 'L', N, cov_cho_factor, N, rc )
        call DPOTRS( 'L', N, 1, cov_cho_factor, N, yy_m, N, rc )
!         call cpu_time(time2)
!         print '("Time for cholesky = ",f6.3," seconds.")',time2-time1

        !call choly(0, N, cov_cho_factor, yy, xsol, rc)

        if (rc /= 0) STOP 'Error in cholesky. Matrix is not positive definite?'

        xsol = yy_m(:, 1)
        lnlike = - sum(log(get_diagonal(cov_cho_factor))) ! -0.5*log(det K)
        lnlike = lnlike - N*const1 ! -(N/2)*ln(2*pi)
        lnlike = lnlike - 0.5d0 * dot_product(yy, xsol) ! -0.5*r.T*K.I*r with K.I*r from DPOTRS

    end function get_lnlikelihood

    subroutine predict(self, x, y, args, t, mu, cov, yerr)
        ! Predictive distribution of the GP, conditional on data x, y
        ! (and optional data uncertainties yerr) and calculated on
        ! coordinates t. args is passed directly to self%mean_fun.
        ! Predictive mean and covariance in mu and cov, on output.
        class(GP), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x, y, args, t
        real(kind=8), dimension(:), intent(in), optional :: yerr
        real(kind=8), dimension(:), intent(inout) :: mu
        real(kind=8), dimension(:,:), intent(inout) :: cov
        real(kind=8), dimension(size(y)) :: xsol
        real(kind=8), dimension(size(t), size(x)) :: Kxs
        real(kind=8), dimension(size(x), size(t)) :: Kxs_trans
        real(kind=8), dimension(size(y), size(y)) :: cov_cho_factor
        integer :: N, ns, rc

        if (size(x) /= size(y)) STOP 'Dimension mismatch in predict'
        if (size(t) /= size(mu)) STOP 'Dimension mismatch in predict'

        !cov_cho_factor = self%cov
        cov_cho_factor = self%gp_kernel%evaluate_kernel(x, x)
        N = size(y)
        ns = size(t)

        ! optionally add data uncertainties in quadrature to covariance matrix
        if (present(yerr)) then
            if (size(yerr) /= N) STOP 'Dimension mismatch in predict'
            call add_array_to_diagonal(cov_cho_factor, yerr**2)
        end if

        ! solve the linear system using the cholesky method
        call choly(0, N, cov_cho_factor, y-self%mean_fun(x, args), xsol, rc)
        if (rc /= 0) STOP 'Error in choly. Matrix is not positive definite?'

        ! calculate predictive mean
        Kxs = self%gp_kernel%evaluate_kernel(t, x)
        mu = matmul(Kxs, xsol) + self%mean_fun(t, args)

        ! calculate predictive covariance
        Kxs_trans = transpose(Kxs)
        cov = self%gp_kernel%evaluate_kernel(t, t)
        ! LAPACK routine - DPOTRS solves a system of linear equations A*X = B
        !                  using the Cholesky factorization (for matrix B of rhs)
        call DPOTRS( 'L', N, ns, cov_cho_factor, N, Kxs_trans, N, rc )
        !if (rc /= 0) STOP 'Error in choly. Matrix is not positive definite?'
        ! on exit from DPOTRS, Kxs_trans contains the solution matrix
        cov = cov - matmul(Kxs, Kxs_trans)

    end subroutine predict

    function sample_conditional(self, x, y, args, t) result(csamples)
        ! Draw samples (at t) from the predictive distribution, conditional on x,y.
        ! args is passed directly to self%mean_fun
        class(GP), intent(in) :: self
        real(kind=8), dimension(:), intent(in) :: x, y, args, t
        real(kind=8), dimension(size(t)) :: csamples

        real(kind=8), dimension(size(t)) :: mu
        real(kind=8), dimension(size(t), size(t)) :: cov

        mu = 0.d0
        cov = 0.d0

        call self%predict(x, y, args, t, mu, cov)
        csamples = multivariate_normal_sample(mu, cov)

    end function sample_conditional

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!! general functions and subroutines follow !!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    function get_radial_coordinates(x1, x2) result(r)
        ! Get radial coordinates matrix needed by specific kernels
        real(kind=8), dimension(:) :: x1, x2
        real(kind=8), dimension(size(x1), size(x2)) :: r
        integer :: n1, n2

        !if (size(x1) /= size(x2)) STOP 'Dimension mismatch in get_radial_coordinates'
        n1 = size(x1)
        n2 = size(x2)

        r = (spread(x1, 2, n2) - spread(x2, 1, n1))
    end function get_radial_coordinates

    function multivariate_normal_sample(mean, cov) result(s)
        ! Generate samples from a multidimensional Gaussian with covariance matrix cov
        real(kind=8), dimension(:), intent(in) :: mean
        real(kind=8), dimension(:,:), intent(in) :: cov

        real(kind=8), dimension(size(mean)) :: s
        real(kind=8), dimension(size(mean)) :: work  ! scratch array
        real(kind=8), dimension(:), allocatable :: param

        integer :: p
        p = size(mean)
        allocate(param(p*(p+3)/2 + 1))

        ! set up for genmn
        CALL setgmnd(mean, cov, p, param)
        ! actual call to generate sample (in S)
        CALL genmnd(param, s, work)
    end function multivariate_normal_sample

    !
    ! Following code originally from J-P Moreau, Paris (www.jpmoreau.fr)
    !

    subroutine choly(mode, n, a, b, x, rc)
    !======================================================================
    !*                                                                    *
    !*  This procedure solves linear systems :  a * x = b                 *
    !*  for positive definite symmetric n x n matrices a using the        *
    !*  Cholesky method.                                                  *
    !*                                                                    *
    !*  a must be symmetric and positive definite, or the method will     *
    !*  fail. i.e. for all nonzero vectors y we must have y' * a * y > 0  *
    !*                                                                    *
    !*  cholesky uses only the lower triangle of a.                       *
    !*                                                                    *
    !*====================================================================*
    !*                                                                    *
    !*   Application:                                                     *
    !*   ============                                                     *
    !*                                                                    *
    !*      Solve linear systems with positive definite system matrices   *
    !*      efficiently.                                                 *
    !*                                                                    *
    !*====================================================================*
    !*                                                                    *
    !*   Control parameter:                                               *
    !*   ==================                                               *
    !*      mode     integer                                              *
    !*       = 0     Factor matrix a and solve linear system              *
    !*       = 1     Compute factorization only                           *
    !*       = 2     Solve system only; for this call the factorization   *
    !*               must be stored in matrix a from chodec. Used to      *
    !*               solve for many right hand sides.                     *
    !*                                                                    *
    !*   Input parameters:                                                *
    !*   ================                                                 *
    !*      n        integer (n > 0)                                      *
    !*               Dimension of matrix a, size of vectors b and x       *
    !*      a        REAL matrix (n,n)                                    *
    !*                 mode = 0, 1: Matrix of the linear system           *
    !*                 mode = 2   : Cholesky factor                       *
    !*      b        REAL vector (n)        (for mode = 0, 2)             *
    !*               Right hand side of system of equations               *
    !*                                                                    *
    !*   Output parameters:                                               *
    !*   ==================                                               *
    !*      a        REAL matrix (n,n)      (for mode = 0, 1)             *
    !*               Cholesky decomposition of input matrix mat           *
    !*      x        REAL vector (n)        (for mode = 0, 2)             *
    !*               solution vector                                      *
    !*                                                                    *
    !*   Return value rc:                                                 *
    !*   ===============                                                  *
    !*      = 0      all ok                                               *
    !*      = 1      n < 1 or false input parameter                       *
    !*      = 2      Matrix is not positive definite                      *
    !*      = 3      wrong value for mode                                 *
    !*                                                                    *
    !*====================================================================*
    !*                                                                    *
    !*   Procedures in use:                                               *
    !*   =================                                                *
    !*      chodec()  : Factorization                                     *
    !*      chosol()  : Solving system                                    *
    !*                                                                    *
    !======================================================================
    integer mode, rc, n
    real(kind=8) a(0:n-1,0:n-1), b(0:n-1), x(0:n-1)

      rc=3

      if (n < 1) then
        rc=1
        return
      end if

      if (mode.eq.0) then   !Factor matrix and solve system
        call chodec(n, a, rc)
        if (rc.eq.0) then
          call chosol(n, a, b, x, rc)
        end if
      end if

      if (mode.eq.1) then    !Factor only
        call chodec (n, a, rc)
      end if

      if (mode.eq.2) then    !solve only
        call chosol (n, a, b, x, rc)
      end if

      return
    end subroutine choly

    subroutine chodec(n, a, rc)
    !======================================================================
    !*                                                                    *
    !*  chodec decomposes the symmetric positive definite matrix a.       *
    !*                                                                    *
    !*====================================================================*
    !*                                                                    *
    !*   Input parameters:                                                *
    !*   ================                                                 *
    !*      n        integer (n > 0)                                      *
    !*               Dimension of matrix a                                *
    !*      a        REAL matrix (n,n)                                    *
    !*               Matrix of left hand coefficients                     *
    !*                                                                    *
    !*   Output parameter:                                                *
    !*   ================                                                 *
    !*      a        REAL matix (n,n)                                     *
    !*               Cholesky decomposition in the lower triangle         *
    !*                                                                    *
    !*   Return value rc:                                                 *
    !*   ===============                                                  *
    !*      = 0      all ok                                               *
    !*      = 1      n < 1                                                *
    !*      = 2      Matrix not  positive definite                        *
    !*                                                                    *
    !*====================================================================*
    !*                                                                    *
    !*   Functions in use:   dsqrt (square root in double precision)      *
    !*   ================                                                 *
    !*                                                                    *
    !*====================================================================*
    !*                                                                    *
    !*   Constants in use:   EPSQUAD (small number)                       *
    !*   ================                                                 *
    !*                                                                    *
    !======================================================================
    integer rc, n
    real(kind=8)  a(0:n-1,0:n-1)
    real(kind=8) EPSQUAD, sum
    integer i, j, k

      EPSQUAD = 1.d-12

      if (n < 1) then
        rc=1                           ! n < 1  error
        return
      end if

      if (a(0,0) < EPSQUAD) then       ! matrix a not positive definite
        rc=2
        return
      end if
      a(0,0) = dsqrt(a(0,0))
      do j = 1, n-1
        a(j,0) = a(j,0) / a(0,0)
      end do

      do i = 1, n-1
        sum = a(i,i)
        do j = 0, i-1
          sum = sum - a(i,j)*a(i,j)
        end do

        if (sum < EPSQUAD) then         ! matrix a not positive definite
          rc=2
          return
        end if
        a(i,i) = dsqrt(sum)
        do j = i+1, n-1
          sum = a(j,i)
          do k = 0, i-1
            sum = sum - a(i,k) * a(j,k)
          end do
          a(j,i) = sum / a(i,i)
        end do
      end do

      rc = 0  ! all Ok
      return
    end subroutine chodec

    subroutine chosol(n, a, b, x, rc)
    !======================================================================
    !*                                                                    *
    !*  chosol finds the solution x of the linear system B' *  B * x = b  *
    !*  for a lower triangular nonsingular matrix B as supplied in chodec.*
    !*                                                                    *
    !*====================================================================*
    !*                                                                    *
    !*   Input parameters:                                                *
    !*   ================                                                 *
    !*      n        integer  (n > 0)                                     *
    !*               Dimension of matrix a, size of vectors b and x       *
    !*      a        REAL  matrix (n,n)                                   *
    !*               lower triangular matrix as supplied by  chodec       *
    !*      b        REAL  vector (n)                                     *
    !*               Right hand side                                      *
    !*                                                                    *
    !*   Output parameter:                                                *
    !*   =================                                                *
    !*      x        REAL  vector (n)                                     *
    !*               solution vector                                      *
    !*                                                                    *
    !*   Return value rc:                                                 *
    !*   ===============                                                  *
    !*      = 0      all ok                                               *
    !*      = 1      improper lwer triangular matrix or  n < 1            *
    !*                                                                    *
    !======================================================================
    integer rc, n
    real(kind=8) a(0:n-1,0:n-1), b(0:n-1), x(0:n-1)
    real(kind=8) ZERO, sum
    integer j, k

      ZERO = 0.d0

      if (n < 1) then   ! n < 1 error
        rc=1
        return
      end if

      if (a(0,0).eq.ZERO) then               ! improper factor matrix
        rc=1
        return
      end if

      x(0) = b(0) / a(0,0)                   ! update right hand side
      do k = 1, n-1
        sum = ZERO
        do j = 0, k-1
          sum = sum + a(k,j) * x(j)
        end do
        if (a(k,k).eq.ZERO) then
          rc=1
          return
        end if
        x(k) = (b(k) - sum) / a(k,k)
      end do

      x(n-1) = x(n-1) / a(n-1,n-1)            ! back substitution
      do k=n-2, 0, -1
        sum = ZERO
        do j = k+1, n-1
          sum = sum + a(j,k) * x(j)
        end do
        x(k) = (x(k) - sum) / a(k,k)
      end do

      rc = 0  !all ok
      return

    end subroutine chosol

end module gputils


        !COMPILER-GENERATED INTERFACE MODULE: Mon Jul 19 15:11:37 2021
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE LUDCMP__genmod
          INTERFACE
            RECURSIVE SUBROUTINE LUDCMP(A,N,NP,INDX,D)
              INTEGER(KIND=4) :: NP
              REAL(KIND=8) :: A(NP,NP)
              INTEGER(KIND=4) :: N
              INTEGER(KIND=4) :: INDX(NP)
              REAL(KIND=8) :: D
            END SUBROUTINE LUDCMP
          END INTERFACE
        END MODULE LUDCMP__genmod


      Subroutine compute_rirj(nx,ny,n_elems_tot,n_lines_tot,
     &nelems,nlines,rlat,rlon,lat,lon,ri,rj,istatus)
c
c routine generates the ri/rj arrays for mapping laps grid points
c to satellite grid points.
c
      implicit none

      integer i,j,k,l
      integer nx,ny
      integer lstart, kstart
      integer n_lines_tot
      integer n_elems_tot
      integer nlines
      integer nelems
      integer istatus

      real      rlat(n_elems_tot,n_lines_tot)
      real      rlon(n_elems_tot,n_lines_tot)
      real      ri(nx,ny)
      real      rj(nx,ny)
      real      iline,jline
      real      idiff,jdiff

      real      fraclat
      real      fraclon
      real      rlat_diff_deg
      real      rlon_diff_deg

      real      lat(nx,ny)
      real      lon(nx,ny)

      logical   found_line
      logical   found_elem
      logical   first_time

      integer ishow_timer
      integer init_timer
      integer itstatus

      write(6,*)'This could take awhile, maybe hours.'
      write(6,*)'Some output is coming, and timing stats'
      write(6,*)

      itstatus=init_timer()
      itstatus=ishow_timer()

      lstart=nlines
      kstart=1
      do j = 1,ny
         jline = float(j)/10.
         jdiff = jline - int(jline)
c        first_time = .true.
         l=lstart
      do i = 1,nx
         iline = float(i)/10.
         idiff = iline - int(iline)

         if(idiff.eq.0.00 .and. jdiff.eq.0.00)then
            write(6,29)i,j
29          format(1x,'LAPS(i,j) ',2i6)
         end if

         l=lstart
         found_line=.false.
         found_elem=.false.
         do while(.not.found_line)
            if(l.gt.1)then
            k=kstart
            found_elem=.false.
         do while(.not.found_elem)
            if(k.lt.nelems)then

            if(rlat(i,j).ne.0.0.and.rlon(i,j).ne.0.0)then

            if( (lat(i,j).gt.rlat(k,l)       .and.
     &           lat(i,j).le.rlat(k,l-1) )   .and.
     &           (lon(i,j).gt.rlon(k,l)  .and.
     &            lon(i,j).le.rlon(k+1,l))    )then

               rlat_diff_deg=rlat(k,l-1)-rlat(k,l)
               rlon_diff_deg=rlon(k+1,l)-rlon(k,l)
               if(rlat_diff_deg.eq.0.0000000)then
                  write(6,*)i,j,k,l,'rlat_diff=0.0'
               endif
               if(rlon_diff_deg.eq.0.0000000)then
                  write(6,*)i,j,k,l,'rlon_diff=0.0'
               endif

               fraclat=(lat(i,j)-rlat(k,l))/rlat_diff_deg
               fraclon=(lon(i,j)-rlon(k,l))/rlon_diff_deg

               ri(i,j) = float(k)+fraclon
               rj(i,j) = float(l)-fraclat
               found_line=.true.
               found_elem=.true.
c              if(first_time)then
c                 lstart=l
c              endif

            endif
            k=k+1

            endif

            else
               found_elem=.true.
            endif

         enddo

         else
            found_line=.true.
         endif

         l=l-1

         enddo

      enddo
      if(jdiff.eq.0.00)then
         itstatus=ishow_timer()
      end if
      enddo
c ------------------------------------------------------------------------------
900   return
      end


! Written by J. Kas, 2006
! eps2exc takes loss function from loss.dat and gives poles and weights
! corresponding to the many pole model detailed in
! Phys. Rev. B 76, 195116 (2007).
! First, regions are chosen
      PROGRAM eps2exc
      DOUBLE PRECISION Dat(50000,2), g(10000), gamma, omi(10000),
     &     Delta(10000),eps0, sumrl, xNElec, csumrl
      INTEGER i,i1,NPoles,NPts
c     INTEGER ios1,ios2,imax,NFile
      CHARACTER*80 infl, outfl
c     CHARACTER*80 comment
      CHARACTER ch
      EXTERNAL IntGrl
      NPts = 1000
      infl='loss.dat'
      outfl='exc.dat'
      PRINT*, '# Enter number of poles:'
      READ*, NPoles
      ! This input can be used to correct the sumrules
      !PRINT*, '# Enter eps^-1 sumrule and N_el:'
      !READ*, sumrl, xNElec
      sumrl = 1.d0
      xNElec = 1.d0
      PRINT*, 'Is this a metal? (y/n)'
      READ*, ch
      IF(ch.EQ.'y'.OR.ch.EQ.'Y') THEN
         eps0 = -1.d0
      ELSE
         PRINT*, 'Would you like to set the dielectric constant? (y/n)'
         READ*, ch
         IF(ch.EQ.'n'.OR.ch.EQ.'N') THEN
            eps0 = -2.d0
         ELSE

            ! This input can be used to correct the dielectric constant,
            ! which is related to the inverse moment.
            ! Use eps0 = -2 to ignore this correction.
            PRINT*, '# Enter dielectric constant: '
            READ*, eps0
         END IF
      END IF
      PRINT*, eps0
      gamma = 0.01
      csumrl= xNElec/sumrl

      OPEN(unit=12,file=infl,status='old')
      OPEN(unit=13,file=outfl,status='replace')
      CALL rdloss(12,Dat,NPts)

      DO i1 = 1, NPts
         Dat(i1,2) = Dat(i1,2)*csumrl
      END DO
      ! getomi finds poles and weights
      CALL getomi(Dat(1,1), Dat(1,2), NPts, NPoles, omi, g, Delta, eps0)
      WRITE(13,'(A33,I4,A6)') '# Loss function represented with ',
     $     NPoles, ' poles'
      WRITE(13,'(A23,f8.4)') '# Dielectric constant: ', eps0
      DO i = 1, NPoles
         WRITE(13,'(4f20.10)'), omi(i), omi(i)*gamma, g(i), Delta(i)
      END DO

      END


      subroutine mstatp(a,n,xmax,xmin,xrms,xmean,imax)
      implicit real*8 (a-h,o-z)
      dimension a(n)
      if(n.eq.0) then
        xmax=0.d0
        xmin=0.d0
        xmean=0.d0
        xrms=0.d0
        return
      endif

      imax=1
      imin=1
      xmax=a(1)
      xmin=a(1)
      do i=2,n
        if(a(i).ge.xmax) then
          xmax=a(i)
          imax=i
        endif
        if(a(i).le.xmin) then
          xmin=a(i)
          imin=i
        endif
      enddo

      xmean=0.d0
      xrms=0.d0
      do i=1,n
        xmean=xmean+a(i)
        xrms=xrms+a(i)*a(i)
      enddo

      xrms=sqrt(xrms/float(n))
      xmean=xmean/float(n)
      if(xmax.lt.-xmin)then
        imax=imin
      endif
      return
      end


      subroutine balbak(nm,n,low,igh,scale,m,z)
c
      integer i,j,k,m,n,ii,nm,igh,low
      double precision scale(n),z(nm,m)
      double precision s
c
c     this subroutine is a translation of the algol procedure balbak,
c     num. math. 13, 293-304(1969) by parlett and reinsch.
c     handbook for auto. comp., vol.ii-linear algebra, 315-326(1971).
c
c     this subroutine forms the eigenvectors of a real general
c     matrix by back transforming those of the corresponding
c     balanced matrix determined by  balanc.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        low and igh are integers determined by  balanc.
c
c        scale contains information determining the permutations
c          and scaling factors used by  balanc.
c
c        m is the number of columns of z to be back transformed.
c
c        z contains the real and imaginary parts of the eigen-
c          vectors to be back transformed in its first m columns.
c
c     on output
c
c        z contains the real and imaginary parts of the
c          transformed eigenvectors in its first m columns.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      if (m .eq. 0) go to 200
      if (igh .eq. low) go to 120
c
      do 110 i = low, igh
         s = scale(i)
c     .......... left hand eigenvectors are back transformed
c                if the foregoing statement is replaced by
c                s=1.0d0/scale(i). ..........
         do 100 j = 1, m
  100    z(i,j) = z(i,j) * s
c
  110 continue
c     ......... for i=low-1 step -1 until 1,
c               igh+1 step 1 until n do -- ..........
  120 do 140 ii = 1, n
         i = ii
         if (i .ge. low .and. i .le. igh) go to 140
         if (i .lt. low) i = low - ii
         k = scale(i)
         if (k .eq. i) go to 140
c
         do 130 j = 1, m
            s = z(i,j)
            z(i,j) = z(k,j)
            z(k,j) = s
  130    continue
c
  140 continue
c
  200 return
      end


c ------------------------------------------------------------------

        subroutine fixcapaq(val,aux,mitot,mjtot,valc,auxc,mic,mjc,
     &                      nvar,naux,levc,setflags)

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

c
c :::::::::::::::::::::::  FIXCAPAQ ::::::::::::::::::::::::::::::
c  new fine grid solution q was linearly interpolated. but want
c  to conserve kappa*q, not q. calculate the discrepancy
c  in kappa*q using this q, and modify q to account for it.
c ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

      dimension   val(nvar,mitot,mjtot), valc(nvar,mic,mjc)
      dimension   aux(naux,mitot,mjtot), auxc(naux,mic,mjc)
      dimension   setflags(mitot,mjtot)

      dcapamax = 0.d0
      lratiox  = intratx(levc)
      lratioy  = intraty(levc)

      do 10 ic = 2, mic-1
      do 10 jc = 2, mjc-1

       do 15 ivar = 1, nvar

       capaqfine = 0.d0

       do 20 ico = 1, lratiox
       ifine = (ic-2)*lratiox + nghost + ico
       do 20 jco = 1, lratioy
         jfine = (jc-2)*lratioy + nghost + jco
         capaqfine = capaqfine + aux(mcapa,ifine,jfine)*
     &                           val(ivar,ifine,jfine)
20     continue

       dcapaq = auxc(mcapa,ic,jc)*valc(ivar,ic,jc)-
     &          capaqfine/(lratiox*lratioy)
       dcapamax = dmax1(dcapamax,dabs(dcapaq))

       do 30 ico = 1, lratiox
       ifine = (ic-2)*lratiox + nghost + ico
       do 30 jco = 1, lratioy
         jfine = (jc-2)*lratioy + nghost + jco

         if (setflags(ifine,jfine) .eq. NEEDS_TO_BE_SET) then
         ! was set by coarsegrid, need to check for adjustment
           val(ivar,ifine,jfine) = val(ivar,ifine,jfine) +
     &                             dcapaq/aux(mcapa,ifine,jfine)
         endif
30     continue

15     continue

10     continue

c      write(6,*)" max discrepancy ", dcapamax

       return
       end


program monte_carlo_Q1
    use types
    use mcrt_functions

    implicit none

    ! delcaration statements
    real(dp), allocatable :: tau_list(:), total_scatter(:, :), mean_arr(:), length_travelled(:, :)
    real(dp) :: pos(3), nhat(3), old_pos(3)
    real(dp) :: leng, r_max = 200.0*AU, r, tau
    integer :: num_packets, len_tau, j, i, u

    ! ask user for input of the number of packets they would like to run
    ! write(*,*) 'Enter number of num_packets'
    ! read(*,*) num_packets
    num_packets = int(1e5)

    ! memory allocation of different variables now that number of packets is known
    len_tau = 20
    allocate(tau_list(len_tau))
    allocate(total_scatter(len_tau, num_packets))
    allocate(mean_arr(len_tau))
    allocate(length_travelled(len_tau, num_packets))

    write(*,*) 'Program running!'

    ! giving a fixed list of tau values to conform to the question
    ! tau_list = [0.1, 1.0, 5.0, 10.0, 20.0, 50.0, 100.0]
    call linspace(0.1_dp, 50.0_dp, tau_list)

    ! begin to loop over the tau values
    do j = 1, size(tau_list)
        ! for ease of use, define a value of tau as just being the current tau that is running
        tau = tau_list(j)

        ! loop over every packet in the list
        do i = 1, num_packets
            ! set the packets location to the origin
            r = 0.0_dp
            ! generate zero arrays that can be populated, as Kenny does in the Grid code
            call zeros(pos)
            call zeros(nhat)
            call zeros(old_pos)

            ! set the distance travelled to 0
            length_travelled(j, i) = 0

            ! while the particle remains in the sphere
            do while ((r .le. r_max) .and. (r .ge. 0.0_dp))
                ! store the old position
                old_pos = pos
                ! emit a particle and create a directino
                call mc_emit(nhat)
                ! generate an appropriate length for the particle to travel
                leng = mc_gen_L(tau,r_max)
                ! update the particle location
                call mc_update(pos, nhat, leng)
                ! calculate the length of the r vector
                r = norm(pos)

                if (r < r_max) then
                    ! if the particle remains in the sphere then add a scatter and add the length
                    total_scatter(j,i) = total_scatter(j,i) + 1
                    length_travelled(j, i) = length_travelled(j, i) + leng
                else if (r >= r_max) then
                    ! if the particle has left the sphere then don't add a scatter as it has shot straight out
                    leng = edge_length(old_pos, nhat, r_max)
                    ! increase the length that the particle has travelled based on the direction it was travelling and the location of the spherical surface.
                    length_travelled(j, i) = length_travelled(j, i) + leng
                end if

            end do

        end do
        ! use this to indicate which tau value we are evaluating, helps to see how far it is along
        write(*,*) j
    end do

    ! loop over the list of tau values and calculate the mean number of scatters
    do i = 1, size(tau_list)
        mean_arr(i) = mean(total_scatter(i,:))
    end do

    ! open a file ready for writing and then loop over the data and write it out
    open(newunit = u, file = "Q1/Data_nb1/total_scatters.txt", status = "replace")
    do i = 1, size(tau_list)
        write(u,*) tau_list(i),',' , mean_arr(i)
    end do

    ! open a file ready for writing and then loop over the data and write it out
    open(newunit = u, file = "Q1/Data_nb1/length_travelled.txt", status = "replace")
    do j = 1, size(tau_list)
        do i = 1, num_packets
            write(u,*) tau_list(j) ,',' , length_travelled(j,i)/c
        end do
    end do

end program


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program write_sqg_restart

!============================================================
! read in the model state from a netCDF file and write out
! to a DART readable restart file
!============================================================

   use        types_mod, only : r8
   use    utilities_mod, only : initialize_utilities, finalize_utilities
   use time_manager_mod, only : time_type, set_time
   use  assim_model_mod, only : open_restart_write, awrite_state_restart
   use        model_mod, only : get_model_size, sqg_to_dart, &
                                model_static, get_model_static_data
   use     spectral_mod
   use          sqg_mod, only : init, xy_to_sp, sp_to_xy, write_diag

   implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

   integer :: model_unit, model_size, model_days, model_seconds

   real(r8), allocatable, dimension(:)     :: model_state
   real,     allocatable, dimension(:,:)   :: thxyB, thxyT
   real,     allocatable, dimension(:,:,:) :: theta

   character(len=129) :: infile, operation

   type(time_type)    :: model_time
   type(model_static) :: sqg_static

   call initialize_utilities('write_sqg_restart')

   ! get filename to read from user:
   print*, 'Enter netCDF filename to read [eg. sqgRestart.nc]: '
   read*, infile
   ! add base-state:
   print*, 'add / remove base-state [eg. add/remove/none]: '
   read*, operation
   ! get model time from user:
   print*, 'Enter model time in DAYS, SECONDS [eg. 0 0]: '
   read*, model_days, model_seconds

   model_unit = open_restart_write('sqgRestart')
   model_time = set_time(model_seconds, model_days)
   model_size = get_model_size()
   sqg_static = get_model_static_data()

   ! allocate space for all variables:
   allocate( model_state(model_size) )
   allocate( theta(2*kmax,2*lmax,2)  )
   allocate( thxyB(2*kmax,2*lmax) )
   allocate( thxyT(2*kmax,2*lmax) )

   ! read in the theta fields from the netCDF file:
   call init(infile,thxyB,thxyT)

   ! optionally, add/remove jet:
   if ( trim(operation) .eq. 'add' .or. trim(operation) .eq. 'remove' ) then
      call toggle_base_state(thxyB,thxyT,sqg_static,operation)
   endif

   ! convert theta into DART state-vector:
   theta(:,:,1) = thxyB
   theta(:,:,2) = thxyT
   call sqg_to_dart(theta,model_state)

   ! write to the file:
   call awrite_state_restart(model_time, model_state, model_unit)

   ! deallocate allocated space:
   deallocate( model_state )
   deallocate( theta       )
   deallocate( thxyB ) ; deallocate( thxyT )

   call finalize_utilities('write_sqg_restart')

   stop

contains

subroutine toggle_base_state(thxyB,thxyT,sqg_static,operation)

   implicit none

   real, dimension(2*kmax,2*lmax), intent(inout) :: thxyB, thxyT
   type(model_static),             intent(in)    :: sqg_static
   character(len=*),               intent(in)    :: operation

   complex,  dimension(2*kmax,2*lmax)      :: thspB, thspT
   integer                                 :: j

   if ( trim(operation) .eq. 'add' ) then
      print*,'ADDING base state'
   elseif( trim(operation) .eq. 'remove' ) then
      print*,'REMOVING base state'
   endif

   ! map into spectral space at the same resolution:
   call xy_to_sp(cmplx(thxyB,0.),thspB,2*kmax,2*lmax,kmax,lmax)
   call xy_to_sp(cmplx(thxyT,0.),thspT,2*kmax,2*lmax,kmax,lmax)

   if ( trim(operation) .eq. 'add' ) then
      thspB = thspB + sqg_static%thbB
      thspT = thspT + sqg_static%thbT
   elseif( trim(operation) .eq. 'remove' ) then
      thspB = thspB - sqg_static%thbB
      thspT = thspT - sqg_static%thbT
   endif

   ! map into grid-point space space at the same resolution:
   call sp_to_xy(thspB,thxyB,kmax,lmax,2*kmax,2*lmax)
   call sp_to_xy(thspT,thxyT,kmax,lmax,2*kmax,2*lmax)

   do j = 1, 2*lmax
      if ( trim(operation) .eq. 'add' ) then
         thxyB(:,j) = thxyB(:,j) - sqg_static%lam * real(j-1) * YL/real(2*lmax)
         thxyT(:,j) = thxyT(:,j) - sqg_static%lam * real(j-1) * YL/real(2*lmax)
      elseif( trim(operation) .eq. 'remove' ) then
         thxyB(:,j) = thxyB(:,j) + sqg_static%lam * real(j-1) * YL/real(2*lmax)
         thxyT(:,j) = thxyT(:,j) + sqg_static%lam * real(j-1) * YL/real(2*lmax)
      endif
   enddo

   return
end subroutine toggle_base_state

end program write_sqg_restart

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


      SUBROUTINE ZLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF, D, DF,
     $                   X, WORK, LWORK, RWORK, RESULT )
*
*  -- LAPACK test routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LDB, LWORK, M, N, P
*     ..
*     .. Array Arguments ..
*
*  Purpose
*  =======
*
*  ZLSETS tests ZGGLSE - a subroutine for solving linear equality
*  constrained least square problem (LSE).
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  P       (input) INTEGER
*          The number of rows of the matrix B.  P >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrices A and B.  N >= 0.
*
*  A       (input) COMPLEX*16 array, dimension (LDA,N)
*          The M-by-N matrix A.
*
*  AF      (workspace) COMPLEX*16 array, dimension (LDA,N)
*
*  LDA     (input) INTEGER
*          The leading dimension of the arrays A, AF, Q and R.
*          LDA >= max(M,N).
*
*  B       (input) COMPLEX*16 array, dimension (LDB,N)
*          The P-by-N matrix A.
*
*  BF      (workspace) COMPLEX*16 array, dimension (LDB,N)
*
*  LDB     (input) INTEGER
*          The leading dimension of the arrays B, BF, V and S.
*          LDB >= max(P,N).
*
*  C       (input) COMPLEX*16 array, dimension( M )
*          the vector C in the LSE problem.
*
*  CF      (workspace) COMPLEX*16 array, dimension( M )
*
*  D       (input) COMPLEX*16 array, dimension( P )
*          the vector D in the LSE problem.
*
*  DF      (workspace) COMPLEX*16 array, dimension( P )
*
*  X       (output) COMPLEX*16 array, dimension( N )
*          solution vector X in the LSE problem.
*
*  WORK    (workspace) COMPLEX*16 array, dimension (LWORK)
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.
*
*  RWORK   (workspace) DOUBLE PRECISION array, dimension (M)
*
*  RESULT  (output) DOUBLE PRECISION array, dimension (2)
*          The test ratios:
*            RESULT(1) = norm( A*x - c )/ norm(A)*norm(X)*EPS
*            RESULT(2) = norm( B*x - d )/ norm(B)*norm(X)*EPS
*
*  ====================================================================
*
      DOUBLE PRECISION   RESULT( 2 ), RWORK( * )
      COMPLEX*16         A( LDA, * ), AF( LDA, * ), B( LDB, * ),
     $                   BF( LDB, * ), C( * ), CF( * ), D( * ), DF( * ),
     $                   WORK( LWORK ), X( * )
*     ..
*     .. Local Scalars ..
      INTEGER            INFO
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZCOPY, ZGET02, LA_TEST_ZGGLSE, ZLACPY
*     ..
*     .. Executable Statements ..
*
*     Copy the matrices A and B to the arrays AF and BF,
*     and the vectors C and D to the arrays CF and DF,
*
      CALL ZLACPY( 'Full', M, N, A, LDA, AF, LDA )
      CALL ZLACPY( 'Full', P, N, B, LDB, BF, LDB )
      CALL ZCOPY( M, C, 1, CF, 1 )
      CALL ZCOPY( P, D, 1, DF, 1 )
*
*     Solve LSE problem
*
              INFO = 0
      CALL LA_TEST_ZGGLSE( M, N, P, AF, LDA, BF, LDB, CF, DF,
     &  X, WORK, LWORK, INFO )
*
*     Test the residual for the solution of LSE
*
*     Compute RESULT(1) = norm( A*x - c ) / norm(A)*norm(X)*EPS
*
      CALL ZCOPY( M, C, 1, CF, 1 )
      CALL ZCOPY( P, D, 1, DF, 1 )
      CALL ZGET02( 'No transpose', M, N, 1, A, LDA, X, N, CF, M, RWORK,
     $             RESULT( 1 ) )
*
*     Compute result(2) = norm( B*x - d ) / norm(B)*norm(X)*EPS
*
      CALL ZGET02( 'No transpose', P, N, 1, B, LDB, X, N, DF, P, RWORK,
     $             RESULT( 2 ) )
*
      RETURN
*
*     End of ZLSETS
*
      END


      subroutine gisol(v,n1v,nrow,nsval,sval,x,utb,svdcut,nkeep)
c----------------------------------------------------------------
c        this procedure solves a system of least squares
c  equations by a trucated singular value decomposition.
c  this is approximately equivalent to the moore-penrose
c  generalized inverse solution.  procedure is intimately
c  connected with subroutine lsvdf in imsl software library in
c  that it uses the output of that routine to form the solution.
c  warning - routine assumes singular values are ordered in a
c  decreasing sequence.
c
c  arguments-
c     v - array containing matrix v of singular value decomposition
c         ( svd of a matrix a = u*s*v(trans)
c     n1v - leading dimension of v
c     nrow - number of rows in v.
c     nsval - number of singular values of original matrix
c             decomposed by lsvdf.
c     sval - vector of length at least nsval containing singular
c            values.
c     x - vector of length at least nsval to contain solution.
c     utb - data vector found as the product u(trans)*b by
c           routine lsvdf.  (b is the initial rhs vector in
c           the initial set of equations ax=b)
c           on return the first nkeep elements of vector utb are
c           overwritten by utb(i)/sval(i) .  this is equivalent
c           to the matrix multiplication lambda(-1)*utb.
c     svdcut - cutoff value on singular values.  only the
c              singular values larger than svdcut are used in the
c              final solution.
c     nkeep - number of singular values actually used to obtain
c             the solution.  (i.e. on return this routine found
c             nkeep singular values larger than svdcut)
c
c  language - 1977 ansi standard fortran
c  written - march 1981
c----------------------------------------------------------------
      real v(n1v,nsval),sval(nsval),utb(nsval),x(nsval)
      nkeep = numbig(sval,nsval,svdcut)
      do 150 i=1,nkeep
          utb(i) = utb(i)/sval(i)
  150 continue
      do 200 i=1,nrow
            x(i) = sdot(nkeep,utb,1,v(i,1),n1v)
  200 continue
      return
      end

c $Id$