c     call var3d (u,v,d,t,up,vp,dp,smsng,dx,dt,dpht,distnf,p,ht
c    &,errwnds,errdds,errmod,io,jo,nx,ny,nz,slat,slon,ter,a9_time)
c
c *** subroutine extracted from test var3d program 1-4-06 JRS.
c *** removed up,vp,dp from argument list as these are not needed
c *** as return variables in calling routine.
c

c     subroutine var3d (u,v,d,t,up,vp,dp,smsng,dx,dt,dpht,distnf,
c    &p,ht,errwnds,errdds,errmod,io,jo,nx,ny,nz,slat,slon,ter)

      subroutine var3d (u,v,d,t,smsng,dx,dt,dpht,distnf,p,ht
     &,errwnds,errdds,errmod,errdis,io,jo,nx,ny,nz,slat,slon,
     &ter,a9_time)

      implicit none

c this subroutine takes in fields of u,v, and density and estimates a
c variance over the grid by determining a weighted difference between
c each grid point and a central profile up,vp,dp. The weighting function is
c a skewed gaussian based on the mean wind
c input  variables
c             u(nx,ny,nz) 3D grid of winds
c             v(nx,ny,nz)     "
c             t(nx,ny,nz) 3D grid of potl temperatures
c             d(nx,ny,nz) density
c             up(nz) U-wind profile at drop point
c             vp(nz) V-wind profile
c             dp(nz) density   profile
c output fields
c             upv(nz) estimated profile variance
c             vpv(nz)
c             dpv(nz)
c internal fields
c             wt(nx,ny)
c             wt3(nx,ny,nz)

       integer ns
       parameter (ns=4)
       integer isave(ns),jsave(ns)
       integer nse
       parameter (nse=2**ns-1)
       integer index(nse),inxx(nse)
       integer inx(nse)
       character*9 a9_time
       character*24 lable,title
       integer nx, ny, nz
       real, intent(in) :: u(nx,ny,nz),v(nx,ny,nz),d(nx,ny,nz)
     &,t(nx,ny,nz)
       real, intent(in) :: slat(nx,ny),slon(nx,ny),ter(nx,ny)

       real upi(nse),vpi(nse),dpi(nse),twi(nse)
       real, allocatable, dimension(:,:) :: wt
       real, allocatable, dimension(:,:,:) :: wt3
       real wtsave(ns),drpx(ns),drpy(ns)
       real alph,beta,sumu,sumv,sumd
       real p(nz),ht(nz)
       real ud(nz),vd(nz),ubb(nz),vbb(nz),wbb(nz),uab(nz),vab(nz)
       real up(nz),vp(nz),dp(nz),tp(nz),dd(nz)
       real upv(nz),vpv(nz),tpv(nz),wp(nz),dpv(nz),
     &      wab(nz),dbb(nz),dab(nz),ubv(nz),vbv(nz),wbv(nz),
     &      uav(nz),vav(nz),wav(nz),utv(nz),vtv(nz),wtv(nz),
     &      dav(nz),dbv(nz),pav(nz),htav(nz),tav(nz)

       real eponexy,gamma,sumw,ca,ddd2,ct,epone
       real ss2,sa,sumt,tpvs,sn2,sumww,sumdd,zter,smax,sumvv,sumuu
       real errmod,dt,dx,smsng,dpht,errdds,errwnds,distnf,st,ubar
       real vbar,vbtot,ubtot,errdis
       real ri,rj,ter_hgt_drop,droplat,droplon

       integer i,j,k,kk,l,mm,lsave,n,lmax,m,in,jo,io, ncnt,ix,jy
       integer ktop,kbot,nofly2,idist2
       integer user_sonde_loc(2)
       integer nofly_area(nx,ny)
       integer istatus

       data index /1,2,3,4,12,13,14,23,24,34,123,124,134,234,1234/

       print*,'Module var3d'
       print*,'nx/ny/nz:      ',nx,ny,nz
       print*,'grid center:   ',io,jo
       print*,'nofly radius:  ',distnf
       print*,'drop height:   ',dpht
       print*,'delta t (sec): ',dt

c find kbot and ktop

c Note: This assumes the grid center of the domain is the drop
c       location for the PADS mission. Ie., drop location is specified
c       by vars grid_cen_lat_cmn & grid_cen_lon_cmn in nest7grid.parms

       call get_grid_center(droplat,droplon,istatus)

       call latlon_to_rlapsgrid(droplat,droplon,slat,slon,nx,ny,ri,rj
     1                                ,istatus)
       call bilinear_laps(ri,rj,nx,ny,ter,ter_hgt_drop)

c   compute ktop
       do k=1,nz
        if (dpht.lt.ht(k)) then
         ktop=k
         go to 5
        endif
       enddo
c   compute kbot
5      do k=1,nz
        if (ht(k).ge.ter_hgt_drop) then
         kbot=k
         go to 6
        endif
       enddo

       if(kbot.gt.ktop)then
          print*,'Error: kbot > ktop in var3dsub '
          print*,'Terminating ', kbot,ktop
          stop
       endif

c determine mean wind and compute profiles

6      sumu=0.
       sumv=0.
       ncnt=0
       do k=kbot,ktop
        do j=1,ny
         do i=1,nx
          if (u(i,j,k).ne.smsng) then
           sumu=sumu+u(i,j,k)
           sumv=sumv+v(i,j,k)
           ncnt=ncnt+1
          endif
         enddo
        enddo
       enddo
       ubar=sumu/float(ncnt)
       vbar=sumv/float(ncnt)
       if(ubar.lt.1.and.ubar.ge.0.) ubar=1
       if(ubar.gt.-1.and.ubar.lt.0.) ubar=-1
       if(vbar.lt.1.and.vbar.ge.0.) vbar=1
       if(ubar.gt.-1.and.ubar.lt.0.) vbar=-1
       print*,'ubar,vbar ',ubar,vbar

c profiles
       ubtot=0.
       vbtot=0.
       print*, 'ktop ', ktop
       print*, 'kbot ', kbot
       print*
       print*, 'Height profile in drop layer'
       do k=kbot,ktop
        print*,'k, ht(m) ',k,ht(k)
        up(k)=u(io,jo,k)
        vp(k)=v(io,jo,k)
        wp(k)=0.
        dp(k)=d(io,jo,k)
        tp(k)=t(io,jo,k)
        ud(k)=up(k)
        vd(k)=vp(k)
        dd(k)=dp(k)
        ubb(k)=0.
        vbb(k)=0.
        wbb(k)=0.
        uab(k)=0.
        vab(k)=0.
        wab(k)=0
        dab(k)=0.
        dbb(k)=0.
        ubv(k)=errmod**2
        vbv(k)=errmod**2
        wbv(k)=errmod**2/10000.
        utv(k)=(.05*up(k))**2
        vtv(k)=(.05*vp(k))**2
        wtv(k)=utv(k)+vtv(k)
        dav(k)=(dp(k)*.01)**2
        pav(k)=(p(k)*.0001)**2
        htav(k)=pav(k)/dp(k)*9.8
       enddo
c compute weight function
       allocate (wt(nx,ny))
c   alpha is the along flow weight tuning parameter based on expected model
c   phase error in meters (errdis), the grid distance dx (m).D=errdis/dx
c   alpha is 1/D**2 making the weight 1/e for distance D (in I,J space)
c   beta is the cross flow fall off value and is set to 3*alpha

       alph=(dx/errdis)**2
       beta=3.*alph
       ix=ubar*dt/dx+.5
       jy=vbar*dt/dx+.5
       print*, 'full wind offset i,j', ix,jy
       st=vbar/sqrt(ubar**2+vbar**2)
       ct=ubar/sqrt(ubar**2+vbar**2)
       do j=1,ny
        do i=1,nx
         ddd2=float(i-io+ix)**2+float(j-jo+jy)**2
         if(ddd2.eq.0.) then
          epone=0.
          go to 33
         endif
         sa=float(j-jo+jy)*st
         ca=float(i-io+ix)*ct
         ss2=(sa+ca)**2
         sn2=ddd2-ss2
         epone= alph*ss2+beta*sn2
  33     wt(i,j)=exp(-epone)
        enddo
       enddo

c compute variance estimate
       allocate (wt3(nx,ny,nz))
       tpvs=0.
       do k=kbot,ktop
        sumu=0.
        sumv=0.
        sumt=0.
        sumw=0.
        do j=1,ny
         do i=1,nx
          if (u(i,j,k).ne.smsng) then
           wt3(i,j,nz)=(wt(i,j)*(u(i,j,k)-up(k)))**2
           sumu=sumu+wt3(i,j,nz)
           wt3(i,j,nz-1)=(wt(i,j)*(v(i,j,k)-vp(k)))**2
           sumv=sumv+wt3(i,j,nz-1)
           wt3(i,j,nz-2)=wt3(i,j,nz)+wt3(i,j,nz-1)
           sumd=sumd+(wt(i,j)*(d(i,j,k)-dp(k)))**2
           sumw=sumw+wt(i,j)
          endif
         enddo
        enddo
c variances for forecast quality
        upv(k)=sumu/sumw !u variance due to model error at drop location
        vpv(k)=sumv/sumw !v variance due to model error at drop location
        tpv(k)=upv(k)+vpv(k) ! total variance
        if(k.le.ktop)tpvs=tpvs+tpv(k)
        dpv(k)=sumd/float(ncnt)
        write(6,1000) 'uv,vv,tot,dv ',upv(k),vpv(k),tpv(k),dpv(k)
 1000   format(1x,a13,4f9.5)
       enddo
       print*,'total variance', tpvs

c sonde emmulator
c recompute weights

c assume every grid location is a sonde
c determine impact on drop location
c recompute ubar and vbar below ktop
       sumu=0.
       sumv=0.
       ncnt=0
       do k=kbot,ktop
        do j=1,ny
         do i=1,nx
          if (u(i,j,k).ne.smsng) then
           sumu=sumu+u(i,j,k)
           sumv=sumv+v(i,j,k)
           ncnt=ncnt+1
          endif
         enddo
        enddo
       enddo
       ubar=sumu/float(ncnt) ! mean wind through drop layer
       vbar=sumv/float(ncnt)
       if(ubar.lt.1.and.ubar.ge.0.) ubar=1
       if(ubar.gt.-1.and.ubar.lt.0.) ubar=-1
       if(vbar.lt.1.and.vbar.ge.0.) vbar=1
       if(ubar.gt.-1.and.ubar.lt.0.) vbar=-1
       print*,'ubar,vbar below ktop ',ubar,vbar
c the tuning parameters alph,beta, and gamma now mimic an isentropic
c elliptical weighting function so values are different from previous
c using correlation distance as a scaling parameter
       alph=(2.*dx/errdis)**2
       beta=2.*alph
       gamma=0.001
       ix=ubar*dt/dx+.5
       jy=vbar*dt/dx+.5
       print*, 'offset i,j in drop layer', ix,jy
       st=vbar/sqrt(ubar**2+vbar**2)
       ct=ubar/sqrt(ubar**2+vbar**2)
       do j=1,ny
        do i=1,nx
         ddd2=float(i+ix-io)**2+float(j+jy-jo)**2
         if(ddd2.eq.0.) then
          eponexy=0.
          go to 333
         endif
         sa=float(j+jy-jo)*st
         ca=float(i+ix-io)*ct
         ss2=(sa+ca)**2
         sn2=ddd2-ss2
         eponexy= alph*ss2+beta*sn2
 333     do k=kbot,nz
          do kk=ktop,kbot,-1
             if(u(i,j,k).ne.smsng) then
                epone=eponexy+gamma*(t(i,j,k)-tp(kk))**2
                wt3(i,j,k)=exp(-epone)
             else
                wt3(i,j,k)=smsng
             endif
          enddo
         enddo
        enddo
       enddo
c now add up all the weights below ktop
       do j=1,ny
        do i=1,nx
         wt(i,j)=0.
         ncnt=0
         do k=kbot,ktop
          if(wt3(i,j,k).ne.smsng) then
           wt(i,j)=wt(i,j)+wt3(i,j,k)
           ncnt=ncnt+1
          endif
         enddo
         wt(i,j)=wt(i,j)/float(ncnt)
        enddo
       enddo
c now find maximum wt for area
c read PADS input of nofly area file and user sonde location information
      call read_PADS_nofly_and_sonde(nx,ny
     1,nofly_area,user_sonde_loc,istatus)

      idist2=(6.0*dt/dx)**2
      nofly2=(distnf/dx)**2
      do l=1,ns
       smax=0.
       do j=1,ny
        do i=1,nx
         if(wt(i,j).gt.smax) then
          if(((i-io)**2+(j-jo)**2).lt.nofly2) go to 1
          do m=1,l-1
           if(((isave(m)-i)**2+(jsave(m)-j)**2).lt.idist2) go to 1
          enddo
          smax=wt(i,j)
          isave(l)=i
          jsave(l)=j
          wtsave(l)=smax
         endif
    1   enddo
       enddo
       write(6,1001) 'l,is,js,wt ',l,isave(l),jsave(l),wtsave(l)
       drpx(l)=isave(l)
       drpy(l)=jsave(l)
 1001  format(1x,a11, 3i6,f9.5)
      enddo
c compute variance for each sonde set or scenario
      lmax=2**ns-1
      do l=1,lmax
       call decode_index(l,index,in,inx,lmax,ns)
       sumu=0.
       sumv=0.
       sumd=0.
       sumw=0.
       do k=kbot,ktop
        sumuu=0.
        sumvv=0.
        sumdd=0.
        sumww=0.
        do m=1,in
         mm=inx(m)
         sumuu=sumuu+wt3(isave(mm),jsave(mm),k)*errwnds
         sumvv=sumvv+wt3(isave(mm),jsave(mm),k)*errwnds
         sumdd=sumdd+wt3(isave(mm),jsave(mm),k)*errdds
         sumww=sumww+wt3(isave(mm),jsave(mm),k)
        enddo
c sum over ktop levels
        sumw=sumw+1.
        uav(k)=((sumuu+sqrt(upv(k)))/(sumww+1.))**2
        vav(k)=((sumvv+sqrt(vpv(k)))/(sumww+1.))**2
        tav(k)=uav(k)+vav(k)
        dav(k)=((sumdd+sqrt(dpv(k)))/(sumww+1.))**2
        sumu=sumu+uav(k)
        sumv=sumv+vav(k)
        sumd=sumd+dav(k)
c       write(6,1002) 'Anvar sen,u,v,tot,den ',index(l),uav(k),
c    &                 vav(k),tav(k),dav(k)

 1002   format(1x,a22,i6,4f9.5)
       enddo

       upi(l)=(sumu/sumw)
       vpi(l)=(sumv/sumw)
       twi(l)=upi(l)+vpi(l)
       dpi(l)=(sumd/sumw)
       write(6,1003)'scenario ',index(l),' uvar ',upi(l),' vvar ',vpi(l)
     & ,' tot  ',twi(l),' denvar ',dpi(l),' pct  ',twi(l)/tpvs*100.
 1003  format(1x,a9,i6,3(a6,f6.3),a8,f7.5,a6,f6.3)
c determine variance minimum
      call write_plan_errors(a9_time,p,ht,up,vp,wp,tp,dp,ud,vd,
     & ubb,vbb,wbb,uab,vab,wab,dbb,dab,vbtot,vbtot,ubv,vbv,wbv
     & ,uav,vav,wav,utv,vtv,wtv,dav,dbv,pav,htav,io,jo,nz,zter
     & ,index(l),99)
      enddo !on l

      deallocate (wt,wt3)

c rank scenarios as a funcion of variance reduction
      do l=1,lmax
       inxx(l)=0
      enddo
      do l=1,lmax
       smax=1.e30
       do m=1,lmax
        do n=1,l
         if(m.eq.inxx(n)) go to 34
        enddo
        if (twi(m).le.smax) then
         lsave =m
         smax=twi(m)
        endif
  34   enddo
       inxx(l)=lsave
      enddo
      do l=1,lmax
       m=inxx(l)
       write(6,1004) l, ' scenario ',index(m),' totl vari ',twi(m),
     &   ' pct reduction ', (1.-twi(m)/tpvs)*100.
 1004 format(1x,i2,a10,i6,a11,f9.5,a15,f7.3)
      enddo

      return
      end

      subroutine decode_index(l,index,in,inx,lmax,ns)
c this routine takes in an integer index (l) and breaks it down into
c individual members in array inx, counts the members..in
c example input 123, inx(l) is 3, 2, 1, and in=3
      integer index(lmax),in,inx(lmax)
      do i100000=0,9
       do i10000=0,9
        do i1000=0,9
         do i100=0,9
          do i10=0,9
           do i1=0,9
            iii=i100000*100000+i10000*10000+i1000*1000+
     &          i100*100+i10*10+i1
            if(index(l).eq.iii) then
             do ie=1,6
              if(iii.lt.10**ie) then
               in=ie
               go to 1
              endif
             enddo
    1        inx(1)=i1
             inx(2)=i10
             inx(3)=i100
             inx(4)=i1000
             inx(5)=i10000
             inx(6)=i100000
             return
            endif
           enddo
          enddo
         enddo
        enddo
       enddo
      enddo
       print*, index(l), "error in index...sonde scenario not found"
       return
       end

c
      subroutine write_plan_errors(a9_time,p,ht,up,vp,wp,tp,dp,ud,vd,
     & ubb,vbb,wbb,uab,vab,wab,dbb,dab,ubtot,vbtot,ubv,vbv,wbv
     & ,uav,vav,wav,utv,vtv,wtv,dav,dbv,pav,htav,io,jo,nz,zter,indx,alt)
c this routine writes an ascii file to the output log summarizing errors
      integer lun
      integer alt,li,lend,indx
      real p(nz),ht(nz)
       real up(nz),vp(nz),wp(nz),dp(nz),tp(nz)
       real ud(nz),vd(nz),ubb(nz),vbb(nz),wbb(nz),uab(nz),vab(nz),
     &      wab(nz),dbb(nz),dab(nz),ubv(nz),vbv(nz),wbv(nz),
     &      uav(nz),vav(nz),wav(nz),utv(nz),vtv(nz),wtv(nz),
     &      dav(nz),dbv(nz),pav(nz),htav(nz)
      real rri(nz),rrj(nz)
      character*200 cfname_out
      character*9   a9_time
      character*4   cindx
c
c direct output to lapsprd/balance/pln/yyjjjhhmm.pln"scenario" -- ascii output
c
      call get_directory('balance',cfname_out,lend)

      if(alt.eq.0)then
         cfname_out=cfname_out(1:lend)//'air/'//a9_time//'.air'
c        call s_len(cfname_out,lend)
         print*,'Airdrop output filename: ',cfname_out(1:lend)
         lun = 20
         open(lun,file=cfname_out,form='formatted',status='unknown'
     +,err=909)

      elseif(alt.eq.1)then
         cfname_out=cfname_out(1:lend)//'air/'//a9_time//'.airp1'
c        call s_len(cfname_out,lend)
         print*,'Airdrop output filename: ',cfname_out(1:lend)
         lun = 20
         open(lun,file=cfname_out,form='formatted',status='unknown'
     +,err=909)

      elseif(alt.eq.2)then
         cfname_out=cfname_out(1:lend)//'air/'//a9_time//'.airp2'
c        call s_len(cfname_out,lend)
         print*,'Airdrop output filename: ',cfname_out(1:lend)
         lun = 20
         open(lun,file=cfname_out,form='formatted',status='unknown'
     +,err=909)

      elseif(alt.eq.99)then
         write(cindx,'(i4)')indx
         search_len: do li=4,1,-1
              if(cindx(li:li).eq.' ')then
                exit search_len
              endif
         enddo search_len
         li=li+1
         if(li.le.1)li=1
         call s_len(cfname_out,lend)
         cfname_out=cfname_out(1:lend)//'pln/'//a9_time//
     +'.pln'//cindx(li:4)
c        print*,'Airdrop planning output filename: ',cfname_out(1:lend)
         lun = 20
         open(lun,file=cfname_out,form='formatted',status='unknown'
     +,err=909)

      endif

  11  r=287.04
      sum=0
      sum1=0
      sum2=0

      if(alt.ne.99)then
         write(lun,1011)
      else
         write(lun,1050)
      endif
 1011 format(6x,'************AIRDROP OUTPUT**************')
 1050 format(6x,'*******AIRDROP PLANNING OUTPUT**********')
      if(alt.ne.99)then
         write(lun,1012)
      else
         write(lun,1052)
      endif
 1012 format(6x,'AIRDROP PROFILES FROM LAPS ANALYSIS')
 1052 format(6x,'PLANNING PROFILES FROM LAPS ANALYSIS')
      write(lun,1013)
 1013 format(4x,'P',6x,'HT',6x,'U',8x,'V',8x,'W',8x,'T',7x,'Den')
      write(lun,1014)
 1014 format(3x,'mb',7x,'m',5x,'m/sec',4x,'m/sec',4x,'m/sec',6x,'K'
     +,6x,'kg/m3')
       ii=io
       jj=jo
      do k=1,nz
       if(zter.lt.ht(k)) then
        write(lun,1005) p(k)/100., ht(k),up(k),
     1  vp(k),wp(k),tp(k),dp(k)
       endif
      enddo
      write(lun,1015)
       write(lun,1022)
 1022 format(6x,'DROPSONDE AND BACKGROUND WIND PROFILES  ')
      write(lun,1023)
 1023 format(4x,'P',6x,'HT',6x,'UD',7x,'VD',7x,'UB',7x,'VB'
     & ,7x,'TD',7x,'TB')
      write(lun,1024)
 1024 format(3x,'mb',7x,'m',5x,'m/sec',4x,'m/sec',4x,'m/sec',4x,'m/sec'
     +,6x,'K',6x,'K')

       ii=io
       jj=jo
      do k=1,nz
       if(zter.lt.ht(k)) then
        write(lun,1025) p(k)/100., ht(k),ud(k),
     1  vd(k),ud(k),vd(k),tp(k),tp(k)
       endif
      enddo
      write(lun,1015)
 1015 format(/)
      write(lun,1016)
 1016 format(8x, 'BIAS ERROR ESTIMATES')
      write(lun,1082)
      write(lun,1083)
      write(lun,1084)
      do k=1,nz
       if(zter.lt.ht(k)) then
        write(lun,1086) p(k)/100., ht(k),ubb(k),
     1  vbb(k),wbb(k),
     1  uab(k),vab(k),wab(k),sum,sum,sum
       endif
      enddo
      write(lun,1015)
      write(lun,1016)
      write(lun,1017)
 1017 format(1x,'P LVL  HT LVL ')
      write(lun,1009)
      write(lun,1010)
      do k=1,nz
       if(zter.lt.ht(k)) then
       write(lun,1008) p(k)/100., ht(k),sum,sum,sum,sum

       endif
      enddo

      write(lun,1015)
      write(lun,1028)
 1028 format(10x,'TOTAL COLUMN WIND BIAS')
      write(lun,1029) ubtot,vbtot
 1029 format(1x,'U BIAS ',f7.2,' V BIAS ',f7.2)
      write(lun,1015)
      write(lun,1018)
 1018 format(10x,'VARIANCE ESTIMATES')
      write(lun,1002)
      write(lun,1003)
      write(lun,1004)

      do k=1,nz
       ii=rri(k)
       jj=rrj(k)
       if(zter.lt.ht(k)      ) then
        write(lun,1000) p(k)/100., ht(k),ubv(k),
     1  vbv(k),wbv(k),
     1  uav(k),vav(k),wav(k),utv(k),vtv(k),wtv(k),dbv(k),dav(k)
       endif
      enddo

      write(lun,1015)
      write(lun,1019)
 1019 format(3x,'TOTAL VARIANCE ESTIMATES')
      write(lun,1020)
 1020 format( '  P     HT     Analysis + Turbulence ')
      write(lun,1021)
 1021 format( '                    (m2/sec2)  ' )
      write(lun,1007)
 1007 format(19x,'U',8x,'V',9x,'W',6x,'Den',7x,'P',9x,'HT')
 1009 format(19x,'P',8x,'HT',8x,'Density')
 1010 format(19x,'mb',8x,'m',8x,'Back',4x,'Anal')

      do k=1,nz
       ii=rri(k)
       jj=rrj(k)
c combined variance formula - err(3,2,k) contains covariance
       sum=uav(k)+utv(k)
       sum1=vav(k)+vtv(k)
       sum2=wav(k)+wtv(k)
       if(zter.lt.ht(k)) then
        write(lun,1001) p(k)/100., ht(k),
     1 sum,sum1,sum2
     1,dav(k),pav(k),htav(k)
       endif
      enddo
      return

 1000 format(1x,f5.0,f8.0,2(f5.1,f5.1,f5.3),3f5.2,2f8.6)
 1006 format(1x,f5.0,f8.0,2(f5.1,f5.1,f5.3),3f5.2,2f7.4)
 1086 format(1x,f5.0,f8.0,2(f7.1,f7.1,f7.3),3f7.2)
 1002 format(18x,'Background',5x,'Analysis',7x,'Turbulence',5x,
     1'Density')
 1082 format(18x,'Background',12x,'Analysis',12x,'Turbulence')
 1083 format(20x,3('(m/sec)',13x))
 1003 format(20x,3('(m2/sec2)',5x),'(kg2/m6)')
 1004 format(3x,'P',7x,'HT  ',3('  U    V    W  '),'  Bgnd     Anal')
 1084 format(3x,'P',7x,'HT  ',3('   U      V      W    '))
 1001 format(1x,f5.0,f8.0,3f9.3,2f9.6,f9.2)
 1005 format(1x,f5.0,f8.0,5f9.3)
 1025 format(1x,f5.0,f8.0,6f9.3)
 1008 format(1x,f5.0,f8.0,4f9.3)

  909 print*,'Error opening airdrop output file'
      return
      end
C
C -----------
C
      subroutine read_PADS_nofly_and_sonde(nx,ny
     1,nofly_area,user_sonde_loc,istatus)

      implicit none

      character*255 directory
      character*255 cfilespec
      integer     nx,ny
      integer     i,j,idum,jdum
      integer     len_dir
      integer     len_cfspec
      integer     nofly_area(nx,ny)  !output
      integer     user_sonde_loc(2)  !output
      integer     istatus
      logical       L1

      istatus = 0
c first is no-fly-area file
      call get_directory('static',directory,len_dir)
      cfilespec=directory(1:len_dir)//'/'//'no-fly-area.txt'
      call s_len(cfilespec,len_cfspec)
      inquire(file=cfilespec(1:len_cfspec),EXIST=L1)
      if(.not.L1)then   !the file does not exist

         print*,"User file no-fly-area.txt does not exist"
         print*,"file spec: ",cfilespec(1:len_cfspec)
         nofly_area=1       !No restricted fly zones anywhere in domain

      else

         print*,"Reading user provided file no-fly-area.txt"
         open(10,FILE=cfilespec(1:len_cfspec),STATUS="old",ERR=90)
         read(10,*)        !    50   50   : nRows nCols (1,1 = SW corner)
         read(10,*)        !    Row   Col : 1=Fly, 0=No Fly
         do i=1,nx
          do j=1,ny
            read(10,*,err=91,end=92)idum,jdum,nofly_area(i,j)
          enddo
         enddo
         goto 95
92       print*,"!! Warning: End-of-file. ",cfilespec(1:len_cfspec)
95       close(10)

      endif
c second is user provided sonde location file
      cfilespec=directory(1:len_dir)//'/'//'sonde_location.txt'
      call s_len(cfilespec,len_cfspec)
      inquire(file=cfilespec(1:len_cfspec),EXIST=L1)
      user_sonde_loc(1)=-99
      user_sonde_loc(2)=-99
      if(.not.L1)then   !the file does not exist

         print*,"User file sonde_location.txt does not exist"
         print*,"file spec: ",cfilespec(1:len_cfspec)
         print*,"Return missing data (-99) for sonde location"

      else

         print*,"Reading user provided file sonde_location.txt"
         open(11,FILE=cfilespec(1:len_cfspec)
     1,STATUS="old",ERR=90)
         read(11,*,err=91,end=93)user_sonde_loc(1),user_sonde_loc(2)
         goto 96
93       print*,"!! Warning: End-of-file. ",cfilespec(1:len_cfspec)
96       close(11)

      endif
      istatus = 1
      return

 90   print*,"Error opening existing file: "
      print*,"  filename: ",cfilespec(1:len_cfspec)
      return
 91   print*,"Error reading file: ",cfilespec(1:len_cfspec)
      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine set_periodic: set module parameters for periodic
!          calculations in the qmdff module
!

subroutine set_periodic(switch_per,length_x,length_y,length_z,switch_ew, &
    & switch_zahn,brute_force, cut_coul,cut_vdw)
use qmdff
implicit none
integer::i,k
logical::switch_per,switch_ew,brute_force,switch_zahn
integer::ifft
real(kind=8)::length_x,length_y,length_z
real(kind=8)::ewald_accuracy
real(kind=8),allocatable::array(:),bsarray(:)
real(kind=8)::ratio,xhi,xlo,y_par,x_par,eps
real(kind=8)::dens,delta
real(kind=8)::cut_coul,cut_vdw
integer::minfft,maxfft
integer::maxpower
parameter (maxpower=63)
integer::multi(maxpower)
integer::ifront,iback,error,iguess  !for FFTW routines
integer::nthread
real(kind=8)::bohr
parameter(bohr=0.52917721092d0)
!
!    The possible PME grid sizes
!
data multi  /   2,   4,   6,   8,  10,  12,  16,  18,  20, &
         &    24,  30,  32,  36,  40,  48,  50,  54,  60,  &
         &    64,  72,  80,  90,  96, 100, 108, 120, 128,  &
         &    144, 150, 160, 162, 180, 192, 200, 216, 240, &
         &    250, 256, 270, 288, 300, 320, 324, 360, 384, &
         &    400, 432, 450, 480, 486, 500, 512, 540, 576, &
         &    600, 640, 648, 720, 750, 768, 800, 810, 864 /

periodic=switch_per
ewald=switch_ew
zahn=switch_zahn
coul_cut=cut_coul
vdw_cut=cut_vdw/bohr
ewald_brute=brute_force
boxlen_x=length_x
boxlen_y=length_y
boxlen_z=length_z
boxlen_x2=length_x*0.5d0
boxlen_y2=length_y*0.5d0
boxlen_z2=length_z*0.5d0

!
!     set the Coulomb cutoff to half the box length if its value
!     is too small (set it directly to bohr)
!
if (coul_cut .lt. 5d0) then
   coul_cut=min(boxlen_x2,boxlen_y2,boxlen_z2)-0.1d0
end if

!
!     Set the parameters for the Zahn method
!
if (zahn) then
   zahn_a=0.2d0*bohr
   coul_cut=10.d0/bohr
   zahn_acut=zahn_a*coul_cut
   zahn_par=erfc(zahn_acut)/coul_cut**2+2*zahn_a/spi*exp(-zahn_acut**2)/coul_cut
end if
!
!     If the Coulomb cutoff is larger than half the box length,
!     set it to half the box length
!
if (coul_cut .gt. min(boxlen_x2,boxlen_y2,boxlen_z2)) then
   coul_cut=min(boxlen_x2,boxlen_y2,boxlen_z2)-0.1d0
   write(*,*) "Warning: The Coulomb cutoff was chosen too large and will"
   write(*,*) " be set to half the periodic box length."
end if
!
!     Set the value where the smooth switch off of the Coulomb energy
!     near the Coulomb cutoff begins
!
cut_low=coul_cut-4.d0
!
!     set the global Ewald parameters
!
if (ewald) then

   r_ew_cut=7/0.52917721092d0
   sqrt_p=sqrt(-log(ewald_accuracy))

!
!     default grid size for reciprocal part from system dimensions
!
   minfft=16
   maxfft=864
   dens=1.2d0
   delta=1D-8
   ifft=int(boxlen_x*0.52917721092d0*dens-delta)+1
   write(*,*) "Ifft",ifft,ewald

   nfft = maxfft
   do i = maxpower, 1, -1
      k = multi(i)
      if (k .le. maxfft) then
         if (k .ge. ifft)  nfft = k
      end if
   end do
   minfft = 16
   if (nfft .lt. minfft)  nfft = minfft

   write(*,*) "PME grid points per dimension: ",nfft

!
!     Set the fft-parameters for the Smooth Particle Mesh Ewald Method
!
   maxtable=4*nfft
   maxprime=15
   allocate(ffttable(maxtable,3))
   allocate(iprime(maxprime,3))

!
!     Initialize the FFT routines
!
   ifront = -1
   iback = 1
   error = 0
   iguess = 0
   nthread=1
   allocate(qgrid(2,nfft,nfft,nfft))
!call dfftw_init_threads (error)
!call dfftw_plan_with_nthreads (nthread)
   call dfftw_plan_dft_3d (planf,nfft,nfft,nfft,qgrid, &
      &                              qgrid,ifront,iguess)
   call dfftw_plan_dft_3d (planb,nfft,nfft,nfft,qgrid, &
      &                              qgrid,iback,iguess)
!
!     DETERMINATION OF ALPHA EWALD PARAMETER
!
!     set the tolerance value; use of 1.0d-8 results in large
!     Ewald coefficients that ensure continuity in the gradient
!
   eps = 1.0d-8
!
!     get approximate value from cutoff and tolerance
!
   ratio = eps + 1.0d0
   x_par = 0.5d0
   i = 0
   do while (ratio .ge. eps)
      i = i + 1
      x_par = 2.0d0 * x_par
      y_par = x_par * r_ew_cut
      ratio = erfc(y_par) / r_ew_cut
   end do
!
!     use a binary search to refine the coefficient
!
   k = i + 60
   xlo = 0.0d0
   xhi = x_par
   do i = 1, k
      x_par = (xlo+xhi) / 2.0d0
      y_par = x_par * r_ew_cut
      ratio = erfc(y_par) / r_ew_cut
      if (ratio .ge. eps) then
         xlo = x_par
      else
         xhi = x_par
      end if
   end do
   a_ewald = x_par

   write(*,*) "alpha",a_ewald
!
!     Set further parameters for the FFT in SPME
!
   bsorder=5
   allocate (array(bsorder))
   allocate (bsarray(nfft))
!
!     compute and load the moduli values
!
   call bspline (0.0d0,bsorder,array)
   do i = 1, nfft
      bsarray(i) = 0.0d0
   end do
   do i = 1, bsorder
      bsarray(i+1) = array(i)
   end do
   allocate(bsmod1(nfft),bsmod2(nfft),bsmod3(nfft))
   call dftmod (bsmod1,bsarray,nfft,bsorder)
   call dftmod (bsmod2,bsarray,nfft,bsorder)
   call dftmod (bsmod3,bsarray,nfft,bsorder)
!
!     perform deallocation of some local arrays
!
   deallocate (array)
   deallocate (bsarray)

end if

return

end subroutine set_periodic


module spral_ssids_gpu_subtree
  use, intrinsic :: iso_c_binding
  use spral_cuda
  use spral_ssids_gpu_smalloc, only : smalloc, smfreeall, smalloc_setup
  use spral_ssids_contrib, only : contrib_type
  use spral_ssids_datatypes
  use spral_ssids_inform, only : ssids_inform
  use spral_ssids_subtree, only : symbolic_subtree_base, numeric_subtree_base
  use spral_ssids_gpu_datatypes, only : gpu_type, free_gpu_type
  use spral_ssids_gpu_factor, only : parfactor
  use spral_ssids_gpu_solve, only : bwd_solve_gpu, fwd_solve_gpu, d_solve_gpu
  implicit none

  private
  public :: gpu_symbolic_subtree, construct_gpu_symbolic_subtree
  public :: gpu_numeric_subtree, gpu_free_contrib
  ! C interfaces
  public :: spral_ssids_build_child_pointers

  type, extends(symbolic_subtree_base) :: gpu_symbolic_subtree
     integer :: device
     integer :: n
     integer :: sa
     integer :: en
     integer :: nnodes
     integer(long) :: nfactor
     integer(long), dimension(:), allocatable :: nptr
     integer, dimension(:), allocatable :: child_ptr
     integer, dimension(:), allocatable :: child_list
     integer, dimension(:), pointer :: sptr
     integer, dimension(:), allocatable :: sparent
     integer(long), dimension(:), allocatable :: rptr
     integer, dimension(:), pointer :: rlist
     integer, dimension(:), allocatable :: rlist_direct
     ! GPU pointers (copies of the CPU arrays of same name)
     type(C_PTR) :: gpu_nlist = C_NULL_PTR
     type(C_PTR) :: gpu_rlist = C_NULL_PTR
     type(C_PTR) :: gpu_rlist_direct = C_NULL_PTR
     integer(long) :: max_a_idx
   contains
     procedure :: factor
     procedure :: cleanup => symbolic_cleanup
  end type gpu_symbolic_subtree

  type, extends(numeric_subtree_base) :: gpu_numeric_subtree
     logical :: posdef
     integer :: device ! Have own copy as symbolic may be freed first
     type(gpu_symbolic_subtree), pointer :: symbolic
     type(C_PTR) :: stream_handle = C_NULL_PTR
     type(gpu_type) :: stream_data
     type(C_PTR) :: gpu_rlist_with_delays = C_NULL_PTR
     type(C_PTR) :: gpu_rlist_direct_with_delays = C_NULL_PTR
     type(C_PTR) :: gpu_clists = C_NULL_PTR
     type(C_PTR) :: gpu_clists_direct = C_NULL_PTR
     type(C_PTR) :: gpu_clen = C_NULL_PTR
     logical :: host_factors = .false.
     type(smalloc_type), pointer :: alloc => null()
     type(node_type), dimension(:), allocatable :: nodes ! Stores pointers
       ! to information about nodes
     type(contrib_type) :: contrib
     type(C_PTR) :: contrib_wait = C_NULL_PTR
   contains
     procedure :: get_contrib
     procedure :: solve_fwd
     procedure :: solve_diag
     procedure :: solve_diag_bwd
     procedure :: solve_bwd
     procedure :: enquire_posdef
     procedure :: enquire_indef
     procedure :: alter
     procedure :: cleanup => numeric_cleanup
  end type gpu_numeric_subtree

contains

  function construct_gpu_symbolic_subtree(device, n, sa, en, sptr, sparent, &
       rptr, rlist, nptr, nlist, options) result(this)
    implicit none
    class(gpu_symbolic_subtree), pointer :: this
    integer, intent(in) :: device
    integer, intent(in) :: n
    integer, intent(in) :: sa
    integer, intent(in) :: en
    integer, dimension(*), target, intent(in) :: sptr
    integer, dimension(*), target, intent(in) :: sparent
    integer(long), dimension(*), target, intent(in) :: rptr
    integer, dimension(*), target, intent(in) :: rlist
    integer(long), dimension(*), target, intent(in) :: nptr
    integer(long), dimension(2,*), target, intent(in) :: nlist
    class(ssids_options), intent(in) :: options

    integer :: node
    integer :: cuda_error, st

    nullify(this)
    ! print *, "[construct_gpu_symbolic_subtree] device = ", device
    ! Specify which device we're using
    cuda_error = cudaSetDevice(device)
    if (cuda_error .ne. 0) then
       print *, "CUDA error on copy"
       return
    end if

   ! Allocate output
   allocate(this, stat=st)
   if (st .ne. 0) return

   ! Initialise members
   !FIXME: stat
   this%device = device
   this%n = n
   this%sa = sa
   this%en = en-1
   this%nnodes = en-sa
   allocate(this%nptr(this%nnodes+1))
   this%nptr(1:this%nnodes+1) = nptr(sa:en) - nptr(sa) + 1
   this%sptr => sptr(sa:en)
   allocate(this%sparent(this%nnodes))
   this%sparent = sparent(sa:en-1) - sa + 1
   allocate(this%rptr(this%nnodes+1))
   this%rptr(1:this%nnodes+1) = rptr(sa:en) - rptr(sa) + 1
   this%rlist => rlist(rptr(sa):rptr(en)-1)

   ! Calculate derived quantities
   this%max_a_idx = maxval(nlist(1,nptr(sa):nptr(en)-1)) ! needed for aval copy
   this%nfactor = 0
   do node = 1, this%nnodes
      this%nfactor = this%nfactor + &
           (this%sptr(node+1)-this%sptr(node)) * &
           (this%rptr(node+1)-this%rptr(node))
   end do

   ! Build rlist direct
   allocate(this%rlist_direct(this%rptr(this%nnodes+1)-1))
   call build_rlist_direct(n, this%nnodes, this%sparent, this%rptr, &
        this%rlist, this%rlist_direct, st) ! FIXME: st

   ! Build child pointers
   call build_child_pointers(this%nnodes, this%sparent, this%child_ptr, &
        this%child_list, st)

   ! Copy data to device
   cuda_error=0
   call copy_analyse_data_to_device(2*(this%nptr(this%nnodes+1)-1), &
        nlist(:,nptr(sa):nptr(en)-1), rptr(en)-rptr(sa), &
        rlist(rptr(sa):rptr(en)-1), this%rlist_direct, &
        this%gpu_nlist, this%gpu_rlist, this%gpu_rlist_direct, cuda_error)
   if (cuda_error .ne. 0) then
      print *, "CUDA error on copy"
      ! FIXME: error handling
      !select type(inform)
      !type is (ssids_inform_gpu)
      !   inform%cuda_error = cuda_error
      !end select
      !inform%flag = SSIDS_ERROR_CUDA_UNKNOWN
      deallocate(this)
      nullify(this)
      return
   end if
 end function construct_gpu_symbolic_subtree

 subroutine build_child_pointers(nnodes, sparent, child_ptr, child_list, st)
   implicit none
   integer, intent(in) :: nnodes
   integer, dimension(nnodes), intent(in) :: sparent
   integer, dimension(:), allocatable :: child_ptr
   integer, dimension(:), allocatable :: child_list
   integer, intent(out) :: st

   integer :: i, j
   integer, dimension(:), allocatable :: child_next, child_head ! linked
     ! list for children

   ! Setup child_ptr, child_next and calculate work per subtree
   allocate(child_next(nnodes+1), child_head(nnodes+1), child_ptr(nnodes+2), &
        child_list(nnodes), stat=st)
   if (st .ne. 0) return
   child_head(:) = -1
   do i = nnodes, 1, -1 ! backwards so child list is in order
      ! Add to parent's child linked list
      j = min(sparent(i), nnodes+1)
      child_next(i) = child_head(j)
      child_head(j) = i
   end do
   ! Add work up tree, build child_ptr and child_list
   child_ptr(1) = 1
   do i = 1, nnodes+1
      j = child_head(i)
      child_ptr(i+1) = child_ptr(i)
      do while (j .ne. -1)
         child_list(child_ptr(i+1)) = j
         child_ptr(i+1) = child_ptr(i+1) + 1
         j = child_next(j)
      end do
   end do
 end subroutine build_child_pointers

!****************************************************************************
!
! Build a direct mapping (assuming no delays) between a node's rlist and that
! of it's parent such that update can be done as:
! lcol_parent(rlist_direct(i)) = lcol(i)
!
 subroutine build_rlist_direct(n, nnodes, sparent, rptr, rlist, rlist_direct, st)
   implicit none
   integer, intent(in) :: n
   integer, intent(in) :: nnodes
   integer, dimension(nnodes), intent(in) :: sparent
   integer(long), dimension(nnodes+1), intent(in) :: rptr
   integer, dimension(rptr(nnodes+1)-1), intent(in) :: rlist
   integer, dimension(rptr(nnodes+1)-1), intent(out) :: rlist_direct
   integer, intent(out) :: st

   integer :: node, parent
   integer(long) :: ii
   integer, dimension(:), allocatable :: map

   allocate(map(n), stat=st)
   if (st .ne. 0) return

   do node = 1, nnodes
      ! Build a map for parent
      parent = sparent(node)
      if (parent .gt. nnodes) cycle ! root of tree
      do ii = rptr(parent), rptr(parent+1)-1
         map(rlist(ii)) = int(ii-rptr(parent)+1)
      end do

      ! Build rlist_direct
      do ii = rptr(node), rptr(node+1)-1
         rlist_direct(ii) = map(rlist(ii))
      end do
   end do
 end subroutine build_rlist_direct

!****************************************************************************
!
! Copy data generated by analyse phase to GPU
! (Specifically, nlist, rlist and rlist_direct)
!
 subroutine copy_analyse_data_to_device(lnlist, nlist, lrlist, rlist, &
      rlist_direct, gpu_nlist, gpu_rlist, gpu_rlist_direct, cuda_error)
   implicit none
   integer(long), intent(in) :: lnlist
   integer(C_LONG_LONG), dimension(lnlist), target, intent(in) :: nlist
   integer(long), intent(in) :: lrlist
   integer(C_INT), dimension(lrlist), target, intent(in) :: rlist
   integer(C_INT), dimension(lrlist), target, intent(in) :: rlist_direct
   type(C_PTR), intent(out) :: gpu_nlist
   type(C_PTR), intent(out) :: gpu_rlist
   type(C_PTR), intent(out) :: gpu_rlist_direct
   integer, intent(out) :: cuda_error ! Non-zero on error

   ! Copy nlist
   cuda_error = cudaMalloc(gpu_nlist, aligned_size(lnlist*C_SIZEOF(nlist(1))))
   if (cuda_error .ne. 0) return
   cuda_error = cudaMemcpy_h2d(gpu_nlist, C_LOC(nlist), &
        lnlist*C_SIZEOF(nlist(1)))
   if (cuda_error .ne. 0) return

   ! Copy rlist
   cuda_error = cudaMalloc(gpu_rlist, aligned_size(lrlist*C_SIZEOF(rlist(1))))
   if (cuda_error .ne. 0) return
   cuda_error = cudaMemcpy_h2d(gpu_rlist, C_LOC(rlist), &
        lrlist*C_SIZEOF(rlist(1)))
   if (cuda_error .ne. 0) return

   ! Copy rlist_direct
   cuda_error = cudaMalloc(gpu_rlist_direct, aligned_size(lrlist*C_SIZEOF(rlist_direct(1))))
   if (cuda_error .ne. 0) return
   cuda_error = cudaMemcpy_h2d(gpu_rlist_direct, C_LOC(rlist_direct), &
        lrlist*C_SIZEOF(rlist_direct(1)))
   if (cuda_error .ne. 0) return

 end subroutine copy_analyse_data_to_device

 subroutine symbolic_cleanup(this)
   implicit none
   class(gpu_symbolic_subtree), intent(inout) :: this

   integer :: flag

   ! Free GPU arrays if needed
   if (C_ASSOCIATED(this%gpu_nlist)) then
      flag = cudaFree(this%gpu_nlist)
      this%gpu_nlist = C_NULL_PTR
      if (flag .ne. 0) &
           print *, "CUDA error freeing this%gpu_nlist flag = ", flag
   end if
   if (C_ASSOCIATED(this%gpu_rlist)) then
      flag = cudaFree(this%gpu_rlist)
      this%gpu_rlist = C_NULL_PTR
      if (flag .ne. 0) &
           print *, "CUDA error freeing this%gpu_rlist flag = ", flag
   end if
   if (C_ASSOCIATED(this%gpu_rlist_direct)) then
      flag = cudaFree(this%gpu_rlist_direct)
      this%gpu_rlist_direct = C_NULL_PTR
      if (flag .ne. 0) &
           print *, "CUDA error freeing this%gpu_rlist_direct flag = ", flag
   end if
 end subroutine symbolic_cleanup

 function factor(this, posdef, aval, child_contrib, options, inform, scaling)
   implicit none
   class(numeric_subtree_base), pointer :: factor
   class(gpu_symbolic_subtree), target, intent(inout) :: this
   logical, intent(in) :: posdef
   real(wp), dimension(*), target, intent(in) :: aval
   type(contrib_type), dimension(:), target, intent(inout) :: child_contrib
   type(ssids_options), intent(in) :: options
   type(ssids_inform), intent(inout) :: inform
   real(wp), dimension(*), target, optional, intent(in) :: scaling

   type(gpu_numeric_subtree), pointer :: gpu_factor

   type(C_PTR) :: gpu_val, gpu_scaling
   type(C_PTR), dimension(:), allocatable :: gpu_contribs
   integer(long) :: sz
   integer, dimension(:), allocatable :: map ! work array, one copy per
      ! thread. Size (0:n), with 0 index used to track which node current map
      ! refers to.
   type(thread_stats) :: stats ! accumulates per thread statistics that are
      ! then summed to obtain global stats in inform. FIXME: not needed?

   integer :: cuda_error, st

   ! Leave output as null until successful exit
   nullify(factor)

   ! Specify which device we're using
   cuda_error = cudaSetDevice(this%device)
   if (cuda_error .ne. 0) goto 200

   ! Allocate cpu_factor for output
   allocate(gpu_factor, stat=st)
   if (st .ne. 0) goto 10
   gpu_factor%symbolic => this
   gpu_factor%posdef = posdef
   gpu_factor%device = this%device

   ! Allocate memory
   gpu_factor%host_factors = .false.
   allocate(gpu_factor%nodes(this%nnodes+1), stat=st)
   if (st .ne. 0) goto 10
   gpu_factor%nodes(:)%ndelay = 0

   allocate(map(0:this%n), stat=st) ! TODO cleanup
   if (st .ne. 0) goto 10
   map(0) = -1 ! initally map unassociated with any node

   ! Setup child contribution array
   ! Note: only non-NULL where we're passing contributions between subtrees
   allocate(gpu_contribs(this%nnodes), stat=st)
   if (st .ne. 0) goto 10
   gpu_contribs(:) = C_NULL_PTR

   ! Initialise host allocator
   ! * options%multiplier * n             integers (for nodes(:)%perm)
   ! * options%multiplier * (nfactor+2*n) reals    (for nodes(:)%lcol)
   ! FIXME: do we really need this multiplier memory????
   ! FIXME: In posdef case ints and reals not needed!
   !
   ! FIXME: It seems that the memory allocated for the factors should
   ! only be needed when factors are stored on the host.
   allocate(gpu_factor%alloc, stat=st)
   if (st .ne. 0) goto 10
   call smalloc_setup(gpu_factor%alloc, &
        max(this%n+0_long, int(options%multiplier*this%n,kind=long)), &
        max(this%nfactor+2*this%n, &
        int(options%multiplier*real(this%nfactor,wp)+2*this%n,kind=long)), st)
   if (st .ne. 0) goto 10

   ! Copy A values to GPU
   sz = this%max_a_idx
   cuda_error = cudaMalloc(gpu_val, aligned_size(sz*C_SIZEOF(aval(1))))
   if (cuda_error .ne. 0) goto 200
   cuda_error = cudaMemcpy_h2d(gpu_val, C_LOC(aval), sz*C_SIZEOF(aval(1)))
   if (cuda_error .ne. 0) goto 200

   ! Initialize stream and contrib_wait event
   cuda_error = cudaStreamCreate(gpu_factor%stream_handle)
   if (cuda_error .ne. 0) goto 200
   cuda_error = cudaEventCreateWithFlags(gpu_factor%contrib_wait, &
        cudaEventBlockingSync+cudaEventDisableTiming)
   if (cuda_error .ne. 0) goto 200

   ! Call main factorization routine
   if (present(scaling)) then
      ! Copy scaling vector to GPU
      cuda_error = cudaMalloc(gpu_scaling, this%n*C_SIZEOF(scaling(1)))
      if(cuda_error.ne.0) goto 200
      cuda_error = cudaMemcpy_h2d(gpu_scaling, C_LOC(scaling), &
         this%n*C_SIZEOF(scaling(1)))
      if(cuda_error.ne.0) goto 200

      ! Perform factorization
      call parfactor(posdef, this%child_ptr, this%child_list, this%n,         &
           this%nptr, this%gpu_nlist, gpu_val, this%nnodes, gpu_factor%nodes, &
           this%sptr, this%sparent, this%rptr, this%rlist,                    &
           this%rlist_direct, this%gpu_rlist, this%gpu_rlist_direct,          &
           gpu_contribs, gpu_factor%stream_handle, gpu_factor%stream_data,    &
           gpu_factor%gpu_rlist_with_delays,                                  &
           gpu_factor%gpu_rlist_direct_with_delays, gpu_factor%gpu_clists,    &
           gpu_factor%gpu_clists_direct, gpu_factor%gpu_clen,                 &
           gpu_factor%contrib, gpu_factor%contrib_wait, gpu_factor%alloc,     &
           options, stats, ptr_scale=gpu_scaling)
      cuda_error = cudaFree(gpu_scaling)
      if (cuda_error .ne. 0) goto 200
   else
      call parfactor(posdef, this%child_ptr, this%child_list, this%n,         &
           this%nptr, this%gpu_nlist, gpu_val, this%nnodes, gpu_factor%nodes, &
           this%sptr, this%sparent, this%rptr, this%rlist,                    &
           this%rlist_direct, this%gpu_rlist, this%gpu_rlist_direct,          &
           gpu_contribs, gpu_factor%stream_handle, gpu_factor%stream_data,    &
           gpu_factor%gpu_rlist_with_delays,                                  &
           gpu_factor%gpu_rlist_direct_with_delays, gpu_factor%gpu_clists,    &
           gpu_factor%gpu_clists_direct, gpu_factor%gpu_clen,                 &
           gpu_factor%contrib, gpu_factor%contrib_wait, gpu_factor%alloc,     &
           options, stats)
   end if

   cuda_error = cudaFree(gpu_val)
   if (cuda_error .ne. 0) goto 200

   ! Set inform (in cumulative fashion)
   if ((inform%flag .lt. 0) .or. (stats%flag .lt. 0)) then
      inform%flag = min(inform%flag, stats%flag) ! error
   else
      inform%flag = max(inform%flag, stats%flag) ! warning/success
   end if
   if (stats%st .ne. 0) inform%stat = stats%st
   inform%maxfront = max(inform%maxfront, stats%maxfront)
   inform%num_factor = inform%num_factor+stats%num_factor
   inform%num_flops = inform%num_flops+stats%num_flops
   inform%num_delay = inform%num_delay+stats%num_delay
   inform%num_neg = inform%num_neg+stats%num_neg
   inform%num_two = inform%num_two+stats%num_two
   inform%matrix_rank = inform%matrix_rank - stats%num_zero
   if (stats%cuda_error .ne. 0) inform%cuda_error = stats%cuda_error
   if (stats%cublas_error .ne. 0) inform%cublas_error = stats%cublas_error

   ! Success, set result and return
   factor => gpu_factor
   return

   ! Allocation error handler
10 continue
   inform%flag = SSIDS_ERROR_ALLOCATION
   inform%stat = st
   deallocate(gpu_factor, stat=st)
   return

200 continue
   inform%flag = SSIDS_ERROR_CUDA_UNKNOWN
   inform%cuda_error = cuda_error
   deallocate(gpu_factor, stat=st)
   return
 end function factor

 subroutine numeric_cleanup(this)
   implicit none
   class(gpu_numeric_subtree), intent(inout) :: this

   integer :: flag, cuda_error

   ! FIXME: error handling?

   cuda_error = cudaSetDevice(this%device)
   if (cuda_error .ne. 0) then
      print *, "Failed to set device in numeric_cleanup ", cuda_error
      stop
   end if

   ! Skip if nothing intialized
   if (.not. allocated(this%nodes)) return

   !
   ! Now cleanup GPU-specific stuff
   !
   call free_gpu_type(this%stream_data, flag)

   ! CPU-side allocator
   call smfreeall(this%alloc)
   deallocate(this%alloc)
   nullify(this%alloc)

   ! Cleanup top-level presolve info
   if (C_ASSOCIATED(this%gpu_rlist_with_delays)) then
      flag = cudaFree(this%gpu_rlist_with_delays)
      this%gpu_rlist_with_delays = C_NULL_PTR
      if (flag .ne. 0) return
   end if
   if (C_ASSOCIATED(this%gpu_clists)) then
      flag = cudaFree(this%gpu_clists)
      this%gpu_clists = C_NULL_PTR
      if (flag .ne. 0) return
   end if
   if (C_ASSOCIATED(this%gpu_clists_direct)) then
      flag = cudaFree(this%gpu_clists)
      this%gpu_clists = C_NULL_PTR
      if (flag .ne. 0) return
   end if
   if (C_ASSOCIATED(this%gpu_clen)) then
      flag = cudaFree(this%gpu_clen)
      this%gpu_clen = C_NULL_PTR
      if (flag .ne. 0) return
   end if

   ! Release event
   flag = cudaEventDestroy(this%contrib_wait)
   if (flag .ne. 0) return
   this%contrib_wait = C_NULL_PTR

   ! Release stream
   flag = cudaStreamDestroy(this%stream_handle)
   if (flag .ne. 0) return
   this%stream_handle = C_NULL_PTR
 end subroutine numeric_cleanup

 function get_contrib(this)
   implicit none
   type(contrib_type) :: get_contrib
   class(gpu_numeric_subtree), intent(in) :: this

   integer :: cuda_error

   cuda_error = cudaSetDevice(this%symbolic%device)

   get_contrib = this%contrib
   get_contrib%owner = 1 ! gpu

   ! Now wait until data copy has finished before releasing result
   ! FIXME: handle cuda_error?
   cuda_error = cudaEventSynchronize(this%contrib_wait)
   ! FIXME: handle cuda_error?
 end function get_contrib

 subroutine gpu_free_contrib(contrib)
   implicit none
   type(contrib_type), intent(inout) :: contrib

   ! FIXME: stat check?
   if (associated(contrib%delay_val)) &
        deallocate(contrib%delay_val)
   nullify(contrib%delay_val)
   if (associated(contrib%val)) &
        deallocate(contrib%val)
   nullify(contrib%val)
 end subroutine gpu_free_contrib

! FIXME: general: push/pop cuda settings at higher level
! FIXME: general: do we need to worry about avoiding unnecessary gpu_x creation?
 subroutine solve_fwd(this, nrhs, x, ldx, inform)
   implicit none
   class(gpu_numeric_subtree), intent(inout) :: this
   integer, intent(in) :: nrhs
   real(wp), dimension(*), intent(inout) :: x
   integer, intent(in) :: ldx
   type(ssids_inform), intent(inout) :: inform

   integer :: r
   integer :: cuda_error

   ! Specify which device we're using
   cuda_error = cudaSetDevice(this%symbolic%device)
   if (cuda_error .ne. 0) goto 200

   ! NB: gpu solve doesn't support nrhs > 1, so just loop instead
   do r = 0, nrhs-1
      call fwd_solve_gpu(this%posdef, this%symbolic%child_ptr,      &
           this%symbolic%child_list, this%symbolic%n,               &
           this%symbolic%nnodes, this%nodes, this%symbolic%rptr,    &
           this%stream_handle, this%stream_data,                    &
           x(r*ldx+1:r*ldx:this%symbolic%n), inform%stat, cuda_error)
      if (inform%stat .ne. 0) goto 100
      if (cuda_error .ne. 0) goto 200
   end do

   return

100 continue
   inform%flag = SSIDS_ERROR_ALLOCATION
   return

200 continue ! CUDA error
   inform%cuda_error = cuda_error
   inform%flag = SSIDS_ERROR_CUDA_UNKNOWN
   return
 end subroutine solve_fwd

 ! FIXME: general solve : recover gpu_x memory on error?
 subroutine solve_diag(this, nrhs, x, ldx, inform)
   implicit none
   class(gpu_numeric_subtree), intent(inout) :: this
   integer, intent(in) :: nrhs
   real(wp), dimension(*), intent(inout) :: x
   integer, intent(in) :: ldx
   type(ssids_inform), intent(inout) :: inform

   integer :: r
   integer :: cuda_error

   ! Specify which device we're using
   cuda_error = cudaSetDevice(this%symbolic%device)
   if (cuda_error .ne. 0) goto 200

   ! NB: gpu solve doesn't support nrhs > 1, so just loop instead
   do r = 0, nrhs-1
      call d_solve_gpu(this%symbolic%nnodes, this%symbolic%sptr,    &
           this%stream_handle, this%stream_data, this%symbolic%n,   &
           x(r*ldx+1:r*ldx:this%symbolic%n), inform%stat, cuda_error)
      if (inform%stat .ne. 0) goto 100
      if (cuda_error .ne. 0) goto 200
   end do

   return

100 continue
   inform%flag = SSIDS_ERROR_ALLOCATION
   return

200 continue ! CUDA error
   inform%cuda_error = cuda_error
   inform%flag = SSIDS_ERROR_CUDA_UNKNOWN
   return
 end subroutine solve_diag

 subroutine solve_diag_bwd(this, nrhs, x, ldx, inform)
   implicit none
   class(gpu_numeric_subtree), intent(inout) :: this
   integer, intent(in) :: nrhs
   real(wp), dimension(*), intent(inout) :: x
   integer, intent(in) :: ldx
   type(ssids_inform), intent(inout) :: inform

   integer :: r
   integer :: cuda_error

   ! Specify which device we're using
   cuda_error = cudaSetDevice(this%symbolic%device)
   if (cuda_error .ne. 0) goto 200

   ! NB: gpu solve doesn't support nrhs > 1, so just loop instead
   do r = 0, nrhs-1
      call bwd_solve_gpu(SSIDS_SOLVE_JOB_DIAG_BWD, this%posdef,     &
           this%symbolic%n, this%stream_handle, this%stream_data,   &
           x(r*ldx+1:r*ldx:this%symbolic%n), inform%stat, cuda_error)
      if (inform%stat .ne. 0) goto 100
      if (cuda_error .ne. 0) goto 200
   end do

   return

100 continue
   inform%flag = SSIDS_ERROR_ALLOCATION
   return

200 continue ! CUDA error
   inform%cuda_error = cuda_error
   inform%flag = SSIDS_ERROR_CUDA_UNKNOWN
   return
 end subroutine solve_diag_bwd

 subroutine solve_bwd(this, nrhs, x, ldx, inform)
   implicit none
   class(gpu_numeric_subtree), intent(inout) :: this
   integer, intent(in) :: nrhs
   real(wp), dimension(*), intent(inout) :: x
   integer, intent(in) :: ldx
   type(ssids_inform), intent(inout) :: inform

   integer :: r
   integer :: cuda_error

   ! Specify which device we're using
   cuda_error = cudaSetDevice(this%symbolic%device)
   if (cuda_error .ne. 0) goto 200

   ! NB: gpu solve doesn't support nrhs > 1, so just loop instead
   do r = 0, nrhs-1
      call bwd_solve_gpu(SSIDS_SOLVE_JOB_BWD, this%posdef, this%symbolic%n, &
           this%stream_handle, this%stream_data,                            &
           x(r*ldx+1:r*ldx:this%symbolic%n), inform%stat, cuda_error)
      if (inform%stat .ne. 0) goto 100
      if (cuda_error .ne. 0) goto 200
   end do

   return

100 continue
   inform%flag = SSIDS_ERROR_ALLOCATION
   return

200 continue ! CUDA error
   inform%cuda_error = cuda_error
   inform%flag = SSIDS_ERROR_CUDA_UNKNOWN
   return
 end subroutine solve_bwd

 subroutine enquire_posdef(this, d)
   implicit none
   class(gpu_numeric_subtree), target, intent(in) :: this
   real(wp), dimension(*), target, intent(out) :: d

   integer :: blkn, blkm
   integer(long) :: i
   integer :: j
   integer :: node
   integer :: piv
   integer :: cuda_error

   type(node_type), pointer :: nptr

   ! Specify which device we're using
   cuda_error = cudaSetDevice(this%symbolic%device)
   ! FIXME: error handling

   !if(.not. this%host_factors) then
   !   ! FIXME: Not implemented enquire_posdef for GPU without host factors yet
   !   inform%flag = SSIDS_ERROR_UNIMPLEMENTED
   !   return
   !endif

   piv = 1
   do node = 1, this%symbolic%nnodes
      nptr => this%nodes(node)
      blkn = this%symbolic%sptr(node+1) - this%symbolic%sptr(node)
      blkm = int(this%symbolic%rptr(node+1) - this%symbolic%rptr(node))
      i = 1
      do j = 1, blkn
         d(piv) = nptr%lcol(i)
         i = i + blkm + 1
         piv = piv + 1
      end do
   end do
 end subroutine enquire_posdef

 subroutine enquire_indef(this, piv_order, d)
   implicit none
   class(gpu_numeric_subtree), target, intent(in) :: this
   integer, dimension(*), target, optional, intent(out) :: piv_order
   real(wp), dimension(2,*), target, optional, intent(out) :: d

   integer :: blkn, blkm
   integer :: j, k
   integer :: n
   integer :: nd
   integer :: node
   integer(long) :: offset
   integer :: piv
   real(C_DOUBLE), dimension(:), allocatable, target :: d2
   type(C_PTR) :: srcptr
   integer, dimension(:), allocatable :: lvllookup
   integer :: st, cuda_error
   real(wp) :: real_dummy

   type(node_type), pointer :: nptr

   cuda_error = cudaSetDevice(this%symbolic%device)
   ! FIXME: error handling

   if (this%host_factors) then
      ! Call CPU version instead
      call enquire_indef_gpu_cpu(this, piv_order=piv_order, d=d)
      return
   end if

   !
   ! Otherwise extract information from GPU memory
   !

   n = this%symbolic%n
   if (present(d)) then
      ! ensure d is not returned undefined
      d(1:2,1:n) = 0.0
   end if

   allocate(lvllookup(this%symbolic%nnodes), d2(2*this%symbolic%n), stat=st)
   if (st .ne. 0) goto 100

   piv = 1
   do node = 1, this%symbolic%nnodes
      nptr => this%nodes(node)
      j = 1
      nd = nptr%ndelay
      blkn = this%symbolic%sptr(node+1) - this%symbolic%sptr(node) + nd
      blkm = int(this%symbolic%rptr(node+1) - this%symbolic%rptr(node)) + nd
      offset = blkm*(blkn+0_long)
      srcptr = c_ptr_plus(nptr%gpu_lcol, offset*C_SIZEOF(real_dummy))
      cuda_error = cudaMemcpy_d2h(C_LOC(d2), srcptr, &
           2*nptr%nelim*C_SIZEOF(d2(1)))
      if (cuda_error .ne. 0) goto 200
      do while (j .le. nptr%nelim)
         if (d2(2*j) .ne. 0) then
            ! 2x2 pivot
            if (present(piv_order))  then
               k = nptr%perm(j)
               piv_order(k) = -piv
               k = nptr%perm(j+1)
               piv_order(k) = -(piv+1)
            end if
            if (present(d)) then
               d(1,piv) = d2(2*j-1)
               d(2,piv) = d2(2*j)
               d(1,piv+1) = d2(2*j+1)
               d(2,piv+1) = 0
            end if
            piv = piv + 2
            j = j + 2
         else
            ! 1x1 pivot
            if (present(piv_order)) then
               k = nptr%perm(j)
               piv_order(k) = piv
            end if
            if (present(d)) then
               d(1,piv) = d2(2*j-1)
               d(2,piv) = 0
            end if
            piv = piv + 1
            j = j + 1
         end if
      end do
   end do

   return ! Normal return

100 continue ! Memory allocation error
   ! FIXME
   !inform%stat = st
   !inform%flag = SSIDS_ERROR_ALLOCATION
   return

200 continue ! CUDA error
   ! FIXME
   !select type(inform)
   !type is (ssids_inform_gpu)
   !   inform%cuda_error = cuda_error
   !end select
   !inform%flag = SSIDS_ERROR_CUDA_UNKNOWN
   return
 end subroutine enquire_indef

 ! Provide implementation for when factors are on host
 subroutine enquire_indef_gpu_cpu(this, piv_order, d)
   implicit none
   class(gpu_numeric_subtree), target, intent(in) :: this
   integer, dimension(*), optional, intent(out) :: piv_order
      ! If i is used to index a variable, its position in the pivot sequence
      ! will be placed in piv_order(i), with its sign negative if it is
      ! part of a 2 x 2 pivot; otherwise, piv_order(i) will be set to zero.
   real(wp), dimension(2,*), optional, intent(out) :: d ! The diagonal
      ! entries of D^{-1} will be placed in d(1,:i) and the off-diagonal
      ! entries will be placed in d(2,:). The entries are held in pivot order.

   integer :: blkn, blkm
   integer :: j, k
   integer :: nd
   integer :: node
   integer(long) :: offset
   integer :: piv

   type(node_type), pointer :: nptr

   piv = 1
   do node = 1, this%symbolic%nnodes
      nptr => this%nodes(node)
      j = 1
      nd = nptr%ndelay
      blkn = this%symbolic%sptr(node+1) - this%symbolic%sptr(node) + nd
      blkm = int(this%symbolic%rptr(node+1) - this%symbolic%rptr(node)) + nd
      offset = blkm*(blkn+0_long)
      do while (j .le. nptr%nelim)
         if (nptr%lcol(offset+2*j).ne.0) then
            ! 2x2 pivot
            if (present(piv_order))  then
               k = nptr%perm(j)
               piv_order(k) = -piv
               k = nptr%perm(j+1)
               piv_order(k) = -(piv+1)
            end if
            if (present(d)) then
               d(1,piv) = nptr%lcol(offset+2*j-1)
               d(2,piv) = nptr%lcol(offset+2*j)
               d(1,piv+1) = nptr%lcol(offset+2*j+1)
               d(2,piv+1) = 0
            end if
            piv = piv + 2
            j = j + 2
         else
            ! 1x1 pivot
            if (present(piv_order)) then
               k = nptr%perm(j)
               piv_order(k) = piv
            end if
            if (present(d)) then
               d(1,piv) = nptr%lcol(offset+2*j-1)
               d(2,piv) = 0
            end if
            piv = piv + 1
            j = j + 1
         end if
      end do
   end do
 end subroutine enquire_indef_gpu_cpu

 subroutine alter(this, d)
   implicit none
   class(gpu_numeric_subtree), target, intent(inout) :: this
   real(wp), dimension(2,*), intent(in) :: d

   integer :: blkm, blkn
   integer(long) :: ip
   integer :: j
   integer :: nd
   integer :: node
   integer :: piv
   real(wp), dimension(:), allocatable, target :: d2
   integer, dimension(:), allocatable :: lvllookup
   type(C_PTR) :: srcptr
   integer :: st, cuda_error
   real(wp) :: real_dummy

   type(node_type), pointer :: nptr

   cuda_error = cudaSetDevice(this%symbolic%device)
   ! FIXME: error handling

   if (this%host_factors) &
        call alter_gpu_cpu(this, d)

   !
   ! Also alter GPU factors if they exist
   !

   ! FIXME: Move to gpu_factors a la host_factors?
   ! FIXME: if statement
   !if (options%use_gpu_solve) then
      allocate(lvllookup(this%symbolic%nnodes), d2(2*this%symbolic%n), stat=st)
      if (st .ne. 0) goto 100

      piv = 1
      do node = 1, this%symbolic%nnodes
         nptr => this%nodes(node)
         nd = nptr%ndelay
         blkn = this%symbolic%sptr(node+1) - this%symbolic%sptr(node) + nd
         blkm = int(this%symbolic%rptr(node+1) - this%symbolic%rptr(node)) + nd
         ip = 1
         do j = 1, nptr%nelim
            d2(ip)   = d(1,piv)
            d2(ip+1) = d(2,piv)
            ip = ip + 2
            piv = piv + 1
         end do
         srcptr = c_ptr_plus(this%nodes(node)%gpu_lcol, &
            blkm*(blkn+0_long)*C_SIZEOF(real_dummy))
         cuda_error = cudaMemcpy_h2d(srcptr, C_LOC(d2), &
            2*nptr%nelim*C_SIZEOF(d2(1)))
         if (cuda_error .ne. 0) goto 200
      end do
   !endif

   return ! Normal return

100 continue ! Memory allocation error
   ! FIXME
   !inform%stat = st
   !inform%flag = SSIDS_ERROR_ALLOCATION
   return

200 continue ! CUDA error
   ! FIXME
   !select type(inform)
   !type is (ssids_inform_gpu)
   !   inform%cuda_error = cuda_error
   !end select
   !inform%flag = SSIDS_ERROR_CUDA_UNKNOWN
   return
 end subroutine alter

 ! Alters D for factors stored on CPU
 subroutine alter_gpu_cpu(this, d)
   implicit none
   class(gpu_numeric_subtree), target, intent(inout) :: this
   real(wp), dimension(2,*), intent(in) :: d  ! The required diagonal entries
     ! of D^{-1} must be placed in d(1,i) (i = 1,...n)
     ! and the off-diagonal entries must be placed in d(2,i) (i = 1,...n-1).

   integer :: blkm, blkn
   integer(long) :: ip
   integer :: j
   integer :: nd
   integer :: node
   integer :: piv

   type(node_type), pointer :: nptr

   piv = 1
   do node = 1, this%symbolic%nnodes
      nptr => this%nodes(node)
      nd = nptr%ndelay
      blkn = this%symbolic%sptr(node+1) - this%symbolic%sptr(node) + nd
      blkm = int(this%symbolic%rptr(node+1) - this%symbolic%rptr(node)) + nd
      ip = blkm*(blkn+0_long) + 1
      do j = 1, nptr%nelim
         nptr%lcol(ip)   = d(1,piv)
         nptr%lcol(ip+1) = d(2,piv)
         ip = ip + 2
         piv = piv + 1
      end do
   end do
 end subroutine alter_gpu_cpu

 ! C interfaces

 subroutine spral_ssids_nodes_init(nnodes, c_nodes) bind(C)
   use, intrinsic :: iso_c_binding
   implicit none

   integer(c_int), value :: nnodes
   type(c_ptr) :: c_nodes

   type(node_type), dimension(:), pointer :: nodes
   integer :: st

   c_nodes = c_null_ptr
   allocate(nodes(nnodes+1), stat=st)
   if (st .ne. 0) goto 100
   nodes(:)%ndelay = 0 ! Number of incoming delays
   nodes(:)%nelim = 0 ! Number of eliminated columns

   c_nodes = c_loc(nodes(1))

200 continue
    return
100 continue
    print *, "Error: memory allocation"
    goto 200
 end subroutine spral_ssids_nodes_init

 subroutine spral_ssids_build_rlist_direct(n, nnodes, c_sparent, c_rptr, &
      c_rlist, c_rlist_direct) bind(C)
   implicit none

   integer(c_int), value :: n
   integer(c_int), value :: nnodes
   type(c_ptr), intent(in), value :: c_sparent
   type(c_ptr), intent(in), value :: c_rptr
   type(c_ptr), intent(in), value :: c_rlist
   type(c_ptr), value :: c_rlist_direct

   integer, dimension(:), pointer :: sparent
   integer(long), dimension(:), pointer :: rptr
   integer, dimension(:), pointer :: rlist
   integer, dimension(:), pointer :: rlist_direct
   integer :: st

   if (C_ASSOCIATED(c_sparent)) then
      call C_F_POINTER(c_sparent, sparent, shape=(/ nnodes /))
   else
      print *, "Error c_sparent is NULL"
      return
   end if

   if (C_ASSOCIATED(c_rptr)) then
      call C_F_POINTER(c_rptr, rptr, shape=(/ nnodes+1 /))
   else
      print *, "Error c_rptr is NULL"
      return
   end if

   if (C_ASSOCIATED(c_rlist)) then
      call C_F_POINTER(c_rlist, rlist, shape=(/ rptr(nnodes+1)-1 /))
   else
      print *, "Error c_rlist is NULL"
      return
   end if

   if (C_ASSOCIATED(c_rlist_direct)) then
      call C_F_POINTER(c_rlist_direct, rlist_direct, shape=(/ rptr(nnodes+1)-1 /))
   else
      print *, "Error c_rlist_direct is NULL"
      return
   end if

   call build_rlist_direct(n, nnodes, sparent, rptr, rlist, rlist_direct, st)
   if (st .ne. 0) goto 100

200 continue
    return
100 continue
    print *, "Error memory allocation"
    goto 200
 end subroutine spral_ssids_build_rlist_direct

 subroutine spral_ssids_build_child_pointers(nnodes, c_sparent, c_child_ptr, &
      c_child_list) bind (C)
   implicit none

   integer(c_int), value :: nnodes
   type(c_ptr), intent(in), value :: c_sparent
   type(c_ptr) :: c_child_ptr
   type(c_ptr) :: c_child_list

   integer, dimension(:), pointer :: sparent
   integer, dimension(:), allocatable, target, save :: child_ptr
   integer, dimension(:), allocatable, target, save :: child_list
   integer :: st

   nullify(sparent)
   c_child_ptr = c_null_ptr
   c_child_list = c_null_ptr

   if (C_ASSOCIATED(c_sparent)) then
      call C_F_POINTER(c_sparent, sparent, shape=(/ nnodes /))
   else
      print *, "Error: sparent not associated"
      return
   end if

   call build_child_pointers(nnodes, sparent, child_ptr, child_list, st)
   if (st .ne. 0) goto 100

   c_child_ptr = c_loc(child_ptr(1))
   c_child_list = c_loc(child_list(1))

200 continue
   return
100 continue
   print *, "Error memory allocation"
   goto 200
 end subroutine spral_ssids_build_child_pointers

end module spral_ssids_gpu_subtree


!
! Copyright (c) Stanford University, The Regents of the University of
!               California, and others.
!
! All Rights Reserved.
!
! See Copyright-SimVascular.txt for additional details.
!
! Permission is hereby granted, free of charge, to any person obtaining
! a copy of this software and associated documentation files (the
! "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish,
! distribute, sublicense, and/or sell copies of the Software, and to
! permit persons to whom the Software is furnished to do so, subject
! to the following conditions:
!
! The above copyright notice and this permission notice shall be included
! in all copies or substantial portions of the Software.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!-----------------------------------------------------------------------
!
!     This routine applies penalty-based contact model for possible
!     contacting shell surfaces.
!
!--------------------------------------------------------------------

      SUBROUTINE CONTACTFORCES(Dg)
      USE COMMOD
      USE ALLFUN
      IMPLICIT NONE
      REAL(KIND=RKIND), INTENT(IN) :: Dg(tDof,tnNo)

      LOGICAL :: flag
      INTEGER(KIND=IKIND) :: i, j, k, l, m, iM, jM, e, a, Ac, b, Bc, g,
     2   eNoN, insd, nnb, maxNnb
      REAL(KIND=RKIND) :: kl, hl, w, Jac, al, c, d, pk, nV1(nsd),
     2   nV2(nsd), x1(nsd), x2(nsd), x12(nsd), xmin(nsd), xmax(nsd)

      INTEGER(KIND=IKIND), ALLOCATABLE :: incNd(:), bBox(:,:)
      REAL(KIND=RKIND), ALLOCATABLE :: sA(:), sF(:,:), N(:), Nx(:,:),
     2   gCov(:,:), gCnv(:,:), xl(:,:), lR(:,:)

      IF (eq(cEq)%phys .NE. phys_shell) RETURN

      i  = eq(cEq)%s
      j  = i + 1
      k  = j + 1
      kl = cntctM%k
      hl = cntctM%h

!     Compute normal vectors at each node in the current configuration
      ALLOCATE(sF(nsd,tnNo), sA(tnNo))
      sF = 0._RKIND
      sA = 0._RKIND
      DO iM=1, nMsh
         IF (.NOT.msh(iM)%lShl) CYCLE
         eNoN = msh(iM)%eNoN
         insd = nsd - 1
         ALLOCATE(Nx(insd,eNoN), N(eNoN), xl(nsd,eNoN), gCov(nsd,insd),
     2      gCnv(nsd,insd))
         Nx = msh(iM)%Nx(:,:,1)
         DO e=1, msh(iM)%nEl
            DO a=1, eNoN
               Ac = msh(iM)%IEN(a,e)
               xl(1,a) = x(1,Ac) + Dg(i,Ac)
               xl(2,a) = x(2,Ac) + Dg(j,Ac)
               xl(3,a) = x(3,Ac) + Dg(k,Ac)
            END DO
            CALL GNNS(eNoN, Nx, xl, nV1, gCov, gCnv)
            Jac = SQRT(NORM(nV1(:)))
            nV1(:) = nV1(:)/Jac

            DO g=1, msh(iM)%nG
               w = msh(iM)%w(g) * Jac
               N(:) = msh(iM)%N(:,g)
               DO a=1, eNoN
                  Ac = msh(iM)%IEN(a,e)
                  sA(Ac) = sA(Ac) + w*N(a)
                  sF(:,Ac) = sF(:,Ac) + w*N(a)*nV1(:)
               END DO
            END DO
         END DO
         DEALLOCATE(N, Nx, xl, gCov, gCnv)
      END DO

      CALL COMMU(sF)
      CALL COMMU(sA)

      DO Ac=1, tnNo
         IF (.NOT.ISZERO(sA(Ac))) sF(:,Ac) = sF(:,Ac)/sA(Ac)
         Jac = SQRT(SUM(sF(:,Ac)**2))
         IF (.NOT.ISZERO(Jac)) sF(:,Ac) = sF(:,Ac) / Jac
      END DO

!     Create a bounding box around possible region of contact and bin
!     the box with neighboring nodes
      maxNnb = 15
 101  maxNnb = maxNnb + 5
      IF (ALLOCATED(bBox)) DEALLOCATE(bBox)
      ALLOCATE(bBox(maxNnb,tnNo))
      bBox = 0
      DO iM=1, nMsh
         IF (.NOT.msh(iM)%lShl) CYCLE
         DO a=1, msh(iM)%nNo
            Ac = msh(iM)%gN(a)
            x1(1) = x(1,Ac) + Dg(i,Ac)
            x1(2) = x(2,Ac) + Dg(j,Ac)
            x1(3) = x(3,Ac) + Dg(k,Ac)

!           Box limits for each node
            xmin(:) = x1(:) - cntctM%c
            xmax(:) = x1(:) + cntctM%c

!           Load the box with neighboring nodes lying within it
            DO jM=1, nMsh
               IF (iM.EQ.jM .OR. .NOT.msh(jM)%lShl) CYCLE
               DO b=1, msh(jM)%nNo
                  Bc = msh(jM)%gN(b)
                  x2(1) = x(1,Bc) + Dg(i,Bc)
                  x2(2) = x(2,Bc) + Dg(j,Bc)
                  x2(3) = x(3,Bc) + Dg(k,Bc)
                  IF (x2(1).GE.xmin(1) .AND. x2(1).LE.xmax(1) .AND.
     2                x2(2).GE.xmin(2) .AND. x2(2).LE.xmax(2) .AND.
     3                x2(3).GE.xmin(3) .AND. x2(3).LE.xmax(3)) THEN
                     DO l=1, maxNnb
                        IF (bBox(l,Ac) .EQ. 0) THEN
                           bBox(l,Ac) = Bc
                           EXIT
                        END IF
                        IF (Bc .GT. bBox(l,Ac)) CYCLE
                        IF (Bc .EQ. bBox(l,Ac)) EXIT
                        IF (bBox(maxNnb,Ac) .NE. 0) GOTO 101
                        DO m=maxNnb, l+1, -1
                           bBox(m,Ac) = bBox(m-1,Ac)
                        END DO
                        bBox(l,Ac) = Bc
                        EXIT
                     END DO
                     IF (l .GT. maxNnb) GOTO 101
                  END IF
               END DO ! b
            END DO ! jM
         END DO ! a
      END DO ! iM

!     Check if any node is strictly involved in contact and compute
!     corresponding penalty forces assembled to the residue
      ALLOCATE(lR(dof,tnNo), incNd(tnNo))
      lR    = 0._RKIND
      incNd = 0
      DO Ac=1, tnNo
         IF (bBox(1,Ac) .EQ. 0) CYCLE
         x1(1)  = x(1,Ac) + Dg(i,Ac)
         x1(2)  = x(2,Ac) + Dg(j,Ac)
         x1(3)  = x(3,Ac) + Dg(k,Ac)
         nV1(:) = sF(:,Ac)
         nNb    = 0
         DO a=1, maxNnb
            Bc = bBox(a,Ac)
            IF (Bc .EQ. 0) CYCLE
            x2(1)  = x(1,Bc) + Dg(i,Bc)
            x2(2)  = x(2,Bc) + Dg(j,Bc)
            x2(3)  = x(3,Bc) + Dg(k,Bc)
            nV2(:) = sF(:,Bc)

            x12 = x1(:) - x2(:)
            c   = SQRT(NORM(x12))
            al  = SQRT(ABS(NORM(nV1, nV2)))

            IF (c.LE.cntctM%c .AND. al.GE.cntctM%al) THEN
               d = NORM(x12, nV2)
               flag = .FALSE.
               IF (d.GE.-cntctM%h .AND. d.LT.0._RKIND) THEN
                  pk = 0.5_RKIND*kl/hl * (d + hl)**2._RKIND
                  flag = .TRUE.
               ELSE IF (d .GE. 0._RKIND) THEN
                  pk = 0.5_RKIND*kl * (hl + d)
                  flag = .TRUE.
               ELSE
                  pk = 0._RKIND
               END IF
               IF (flag) THEN
                  incNd(Ac) = 1
                  nNb = nNb + 1
                  lR(1:nsd,Ac) = lR(1:nsd,Ac) - pk*nV1(:)
               END IF
            END IF
         END DO
         IF (nNb .NE. 0) lR(:,Ac) = lR(:,Ac) / REAL(nNb, KIND=RKIND)
      END DO
      DEALLOCATE(sA, sF, bBox)

!     Return if no penalty forces are to be added
      IF (SUM(incNd) .EQ. 0) RETURN

!     Global assembly
      DO Ac=1, tnNo
         IF (incNd(Ac) .EQ. 0) CYCLE
         R(:,Ac) = R(:,Ac) + lR(:,Ac)
      END DO
      DEALLOCATE(lR, incNd)

      RETURN
      END SUBROUTINE CONTACTFORCES
!####################################################################