      program isuba_gmap
      use mod_za  ! HYCOM I/O interface
      use mod_zb  ! HYCOM I/O interface for subregion
      implicit none
c
c     create an array index map to a diferent-grid subregion from a
c     full region hycom file.
c
c     subregion grid is arbitrary, except that any part of this grid
c     that is outside the input grid must be land.
c
c     Alan J. Wallcraft,  NRL,  January 2009.
c
      character*80         :: chead
      character*256        :: flnm_map,flnm_reg
      integer              :: idm_out,jdm_out,
     &                        iref_out,jref_out,iref_in,jref_in
      integer              :: i,ii,ijsafe,ios,ip,itmp,ix,j,jj,jp,jq,l,
     &                        ni,nir,no,nor
      integer              :: k,l0,l1
      logical              :: laxis(2),laxis2,
     &                        lperiod(2),lcycle
      real                 :: hmina,hminb,hmaxa,hmaxb,
     &                        deg2rad,dist,distj,dist_max,
     &                        dx,dy,qdx,xp,yp,plat_min,plat_max
      integer, allocatable :: m_in(:,:),  m_out(:,:)
c
      real,    allocatable :: plat_in( :,:),plon_in( :,:)
      real,    allocatable :: plat_out(:,:),plon_out(:,:)
      integer, allocatable :: i_out(:,:),j_out(:,:)
      real,    allocatable :: x_out(:,:),y_out(:,:)
      real,    allocatable :: plat_in_min(:),plat_in_max(:)
c
      real*4,  parameter   ::  spval=    2.0**100
c
      real*8         ztecnf
      external       ztecnf,ztecng,ztecnp,ztecnb
c
      integer        its
      real*8         acc,err,step
      real*8         x2(2),w(6)
c
      logical        ldebug
      real*8         a,b
      common/zaecnb/ a(0:2,0:2),b(0:2,0:2),ldebug
      save  /zaecnb/
c
      call xcspmd
      call zaiost
      call blkdat(idm_out,jdm_out, chead, flnm_reg,flnm_map)
      call zbiost(idm_out,jdm_out)
c
      allocate(   m_in(idm,jdm),     m_out(idm_out,jdm_out) )
      allocate( plat_in(idm,jdm), plat_out(idm_out,jdm_out) )
      allocate( plon_in(idm,jdm), plon_out(idm_out,jdm_out) )
c
      allocate( plat_in_max(jdm), plat_in_min(jdm) )
c
      allocate( i_out(idm_out,jdm_out), j_out(idm_out,jdm_out) )
      allocate( x_out(idm_out,jdm_out), y_out(idm_out,jdm_out) )
c
c     read the input and output grid locations (no error checking).
c
      nir = 24
      call zaiopf('regional.grid.a','old', nir)
      call zaiord(plon_in,m_in,.false., hmina,hmaxa, nir)
      call zaiord(plat_in,m_in,.false., hmina,hmaxa, nir)
      call zaiocl(nir)
c
      nor = 25
      call zbiopf(trim(flnm_reg),'old', nor)
      call zbiord(plon_out,m_out,.false., hmina,hmaxa, nor)
      call zbiord(plat_out,m_out,.false., hmina,hmaxa, nor)
      call zbiocl(nor)
c
c     calculate the output grid location w.r.t. the input grid.
c
      lperiod(1) = maxval(plon_in(:,:))-
     &             minval(plon_in(:,:))  .gt. 350.0
      do j= 1,jdm
        if     (.not.lperiod(1)) then
          exit
        endif
        dy = mod( abs(plon_in(1,j) - plon_in(  3,j)), 360.0 )
        if     (dy.gt.180.0) then
          dy = 360.0 - dy  !abs distance
        endif
        dx = mod( abs(plon_in(1,j) - plon_in(idm,j)), 360.0 )
        if     (dx.gt.180.0) then
          dx = 360.0 - dx  !abs distance
        endif
        lperiod(1) = lperiod(1) .and. dx.lt.dy  !1 and idm closer than 1 and 3
      enddo
      if     (lperiod(1)) then
        write(6,'(a)') ' input domain assumed to be periodic'
      else
        write(6,'(a)') ' input domain assumed to be non-periodic'
      endif
c
      lperiod(2) = maxval(plon_out(:,:))-
     &             minval(plon_out(:,:))   .gt. 350.0
      do j= 1,jdm_out
        if     (.not.lperiod(2)) then
          exit
        endif
        dy = mod( abs(plon_out(1,j) - plon_out(      3,j)), 360.0 )
        if     (dy.gt.180.0) then
          dy = 360.0 - dy  !abs distance
        endif
        dx = mod( abs(plon_out(1,j) - plon_out(idm_out,j)), 360.0 )
        if     (dx.gt.180.0) then
          dx = 360.0 - dx  !abs distance
        endif
        lperiod(2) = lperiod(2) .and. dx.lt.dy  !1 and idm closer than 1 and 3
      enddo
      if     (lperiod(2)) then
        write(6,'(a)') 'output domain assumed to be periodic'
      else
        write(6,'(a)') 'output domain assumed to be non-periodic'
      endif
c
      laxis(1) = .true.
      do i= 2,idm
        laxis(1) = laxis(1) .and.
     &             maxval(abs(plat_in(1,:)-plat_in(i,:))).le.1.e-2
        if     (.not.laxis(1)) then
          exit
        endif
      enddo
      do j= 2,jdm
        laxis(1) = laxis(1) .and.
     &             maxval(abs(plon_in(:,1)-plon_in(:,j))).le.1.e-2
        if     (.not.laxis(1)) then
          exit
        endif
      enddo
      if     (laxis(1)) then
        write(6,'(a)') ' input domain has 1-d lat/lon axes'
      else
        write(6,'(a)') ' input domain is curvilinear'
      endif
c
      laxis(2) = .true.
      do i= 2,idm_out
        laxis(2) = laxis(2) .and.
     &             maxval(abs(plat_out(1,:)-plat_out(i,:))).le.1.e-2
        if     (.not.laxis(2)) then
          exit
        endif
      enddo
      do j= 2,jdm_out
        laxis(2) = laxis(2) .and.
     &             maxval(abs(plon_out(:,1)-plon_out(:,j))).le.1.e-2
        if     (.not.laxis(2)) then
          exit
        endif
      enddo
      if     (laxis(2)) then
        write(6,'(a)') 'output domain has 1-d lat/lon axes'
      else
        write(6,'(a)') 'output domain is curvilinear'
      endif
      write(6,*)
      call flush(6)
c
      laxis2 = laxis(1) .and. laxis(2)
c
      do j= 1,jdm
        plat_in_min(j) = minval(plat_in(:,j))
        plat_in_max(j) = maxval(plat_in(:,j))
      enddo
      plat_min = minval(plat_in_min(:))
      plat_max = maxval(plat_in_max(:))
      dist_max = 0.0
      do j= 1,jdm-1
        do i= 1,idm-1
          dist_max = max( abs(plat_in(i,j)-plat_in(i+1,j)),
     &                    abs(plat_in(i,j)-plat_in(i,j+1)),
     &                    dist_max )
        enddo
      enddo
      dist_max = 2*dist_max  !target must be at least this close in latitude
c
      deg2rad = 4.d0*atan(1.d0)/180.d0  !pi/180
c
      ldebug = .false.
c
      do jj= 1,jdm_out
        do ii= 1,idm_out
          ldebug = mod(ii,idm_out/10).eq.1 .and.
     &             mod(jj,jdm_out/10).eq.1
c
          if     (laxis2 .and. ii.ne.1 .and. jj.ne.1) then
c
c           shortcut for 1-d axes.
c
            i_out(ii,jj) = i_out(ii,  jj-1)
            j_out(ii,jj) = j_out(ii-1,jj)
            x_out(ii,jj) = x_out(ii,  jj-1)
            y_out(ii,jj) = y_out(ii-1,jj)
            if     (x_out(ii,jj).ne.spval .and.
     &              y_out(ii,jj).ne.spval      ) then
              cycle
            endif
          endif
c
c         find the nearest point by exhaustive search, but improve
c         efficiency by using plat_*_min/_max to exclude far away rows.
c
          xp   = plon_out(ii,jj)
          yp   = plat_out(ii,jj)
*         yp   = min(plat_max,max(plat_min,yp))  !in the input latitude range
          qdx  = max(0.001,abs(cos(yp*deg2rad)))
c
c         start with a nearby point.
c
          if     (ii.eq.1) then
            if     (jj.eq.1) then
              ip = 1
              jp = 1
            elseif (i_out(1,jj-1).ne.spval) then
              ip = i_out(1,jj-1)
              jp = j_out(1,jj-1)
            else
              ip = 1
              jp = 1
            endif
          endif
          dy =      abs(plat_in(ip,jp) - yp)
          dx = mod( abs(plon_in(ip,jp) - xp), 360.0 )
          if     (dx.gt.180.0) then
            dx = 360.0 - dx
          endif
          dist = qdx*dx+dy
          if     (ldebug) then
            write(6,'(a,4i5,3f9.2)')
     &        'ii,jj,ip,jp,dx,dy,dist = ',
     &         ii,jj,ip,jp,dx,dy,dist
            call flush(6)
          endif
c
          lcycle = .false.
          do jq= 0,jdm
            if     (jq.eq.0) then
              j = jp  ! search estimated row location first
            else
              j = jq
            endif
            distj = min(dist,dist_max)
            if     (.not. ldebug) then
              if     (yp.lt.plat_in_min(j)-distj .or.
     &                yp.gt.plat_in_max(j)+distj     ) then
                cycle  ! far away row
              endif
            else !debug
              if     (yp.lt.plat_in_min(j)-distj .or.
     &                yp.gt.plat_in_max(j)+distj     ) then
                if     (.not.lcycle) then
                  write(6,'(a,2i5,5x,i5,f9.2)')
     &              'ii,jj,j,dist (cycle-strt)',
     &               ii,jj,j,dist
                  call flush(6)
                elseif (jq.eq.jdm) then
                  write(6,'(a,2i5,5x,i5,f9.2)')
     &              'ii,jj,j,dist (cycle-stop)',
     &               ii,jj,j,dist
                  call flush(6)
                endif
                lcycle = .true.
                cycle  ! far away row
              else
                if     (lcycle) then
                  write(6,'(a,2i5,5x,i5,f9.2)')
     &              'ii,jj,j,dist (cycle-stop)',
     &               ii,jj,j-1,dist
                  call flush(6)
                endif
                lcycle = .false.
              endif
            endif !.not.ldebug;else
            if     (dist.eq.0.0) then
              exit   ! found exact location
            endif
            do i = 1,idm
              dy =      abs(plat_in(i,j) - yp)
              dx = mod( abs(plon_in(i,j) - xp), 360.0 )
              if     (dx.gt.180.0) then
                dx = 360.0 - dx
              endif
              if     (qdx*dx+dy.lt.dist) then
                ip   = i
                jp   = j
                dist = qdx*dx+dy
                if     (ldebug) then
                  write(6,'(a,4i5,3f9.2)')
     &              'ii,jj,ip,jp,dx,dy,dist = ',
     &               ii,jj,ip,jp,dx,dy,dist
                  call flush(6)
                endif
              endif
            enddo !i
          enddo !j
c
c         convert nearest point into bilinear cell and distances.
c
          if     (dist.eq.0.0) then  !exact location
            if     (ip.eq.idm) then
              i_out(ii,jj) = ip-1
            else
              i_out(ii,jj) = ip
            endif
            x_out(ii,jj) = ip
            if     (jp.eq.jdm) then
              j_out(ii,jj) = jp-1
            else
              j_out(ii,jj) = jp
            endif
            y_out(ii,jj) = jp
          elseif (dist.gt.dist_max) then !outside grid, mark as data void
            if     (ip.eq.idm) then
              i_out(ii,jj) = ip-1
            else
              i_out(ii,jj) = ip
            endif
            x_out(ii,jj) = spval
            if     (jp.eq.jdm) then
              j_out(ii,jj) = jp-1
            else
              j_out(ii,jj) = jp
            endif
            y_out(ii,jj) = spval
          else  !standard case
c
c           find exact location with napack routine(s).
c           over-kill for rectilinear, but neccessary for curvilinear grids.
c
            if     (ip.eq.1   .and. .not.lperiod(1)) then
              ip = 2
            elseif (ip.eq.idm .and. .not.lperiod(1)) then
              ip = idm-1
            endif
            if     (jp.eq.1) then
              jp = 2
            elseif (jp.eq.jdm) then
              jp = jdm-1
            endif
            do j= 0,2
              do i= 0,2
                ix = ip+i-1
                if     (lperiod(1)) then
                  if     (ix.eq.0) then
                    ix = idm
                  elseif (ix.eq.idm+1) then
                    ix = 1
                  endif
                endif
                b(i,j) =      plat_in(ix,jp+j-1) - yp
                a(i,j) = mod( plon_in(ix,jp+j-1) - xp, 360.0 )
                if     (a(i,j).lt.-180.0) then
                  a(i,j) = 360.0 + a(i,j)
                elseif (a(i,j).gt. 180.0) then
                  a(i,j) = a(i,j) - 360.0
                endif
                a(i,j) = qdx*a(i,j)
              enddo !i
            enddo !j
            if     (b(0,1).eq.b(1,1) .and. b(1,1).eq.b(2,1)) then !rectilinear
              x2(1) = ip - a(1,1)/(a(2,1)-a(1,1))
              x2(2) = jp - b(1,1)/(b(1,2)-b(1,1))
            else  !curvilinear
              step   = 0.0
              x2(1)  = 1.0
              x2(2)  = 1.0
              acc    = 1.e-3
              call cg(x2,err,its,step,acc,10,2,2,
     &                ztecnf,ztecng,ztecnb,ztecnp,w, ldebug)
              if     (its.lt.0) then  !very flat extrema
                x2(1)  = 1.0
                x2(2)  = 1.0
              elseif (min(x2(1),x2(2)).lt.-1.0 .or.
     &                max(x2(1),x2(2)).gt. 3.0     ) then  !very bad cg result
                x2(1)  = 1.0
                x2(2)  = 1.0
              endif
              x2(1) = ip + x2(1)-1.0
              x2(2) = jp + x2(2)-1.0
            endif !rectilinear:curvilinear
            if     (lperiod(1) .and. x2(1).gt.idm) then
              i_out(ii,jj) = idm
              x_out(ii,jj) = min( idm+1.d0, x2(1) )
            else
              i_out(ii,jj) = max( 1,    min( idm-1, int(x2(1)) ) )
              x_out(ii,jj) = max( 1.d0,
     &                            min( i_out(ii,jj)+1.d0, x2(1) ) )
            endif
            j_out(ii,jj) = max( 1,    min( jdm-1, int(x2(2)) ) )
            y_out(ii,jj) = max( 1.d0,
     &                          min( j_out(ii,jj)+1.d0, x2(2) ) )
          endif !exact point:else
          if     (ldebug) then
            if     (x_out(ii,jj).ne.spval) then
              write(6,'(a,4i5,3f9.2)')
     &          'ii,jj,i_,j_,x_,y_,dist = ',
     &           ii,jj,i_out(ii,jj),j_out(ii,jj),
     &                 x_out(ii,jj),y_out(ii,jj),dist
            else
              write(6,'(a,4i5,2a,f9.2)')
     &          'ii,jj,i_,j_,x_,y_,dist = ',
     &           ii,jj,i_out(ii,jj),j_out(ii,jj),
     &                 '    spval', '    spval', dist
            endif
            call flush(6)
          endif !ldebug
        enddo !ii
      enddo !jj
c
c     output the grid map file.
c
      no = 15
      l  = len_trim(flnm_map)
      open (unit=no,file=flnm_map(1:l-2)//'.b',form='formatted',
     .      status='new',action='write')
      call zbiopf(flnm_map(1:l-2)//'.a','new', no)
c
      write(no,'(a)') trim(chead)
      call flush(no)
      write(6, *)
      write(6, *)
      write(6, '(a)') trim(chead)
      call flush(6)
c
      call zbiowr(x_out,m_out,.false., hmina,hmaxa, no, .false.)
      write(no,'(a,2f12.4)') 'xmap:  min,max =',hmina,hmaxa
      call flush(no)
      write(6, '(a,2f12.4)') 'xmap:  min,max =',hmina,hmaxa
      call flush(6)
c
      call zbiowr(y_out,m_out,.false., hmina,hmaxa, no, .false.)
      write(no,'(a,2f12.4)') 'ymap:  min,max =',hmina,hmaxa
      call flush(no)
      write(6, '(a,2f12.4)') 'ymap:  min,max =',hmina,hmaxa
      call flush(6)
c
      close(no)
      call zbiocl(no)
c
      end program isuba_gmap

      subroutine blkdat(idm_out,jdm_out, chead, flnm_reg,flnm_map)
      use mod_xc  ! HYCOM communication interface
      implicit none
      integer       :: idm_out,jdm_out
      character*80  :: chead
      character*256 :: flnm_reg,flnm_map
c
c --- read blkdat.input for interpolated subregion.
c
c --- 'flnm_reg'  = output grid       filename
c --- 'flnm_map'  = output grid map   filename
c --- 'chead   '  = single line header for grid map file
c
      read( *,'(a)')      flnm_reg
      write(6,'(a)') trim(flnm_reg)
      read( *,'(a)')      flnm_map
      write(6,'(a)') trim(flnm_map)
      write(6,*)
      read( *,'(a)')      chead
      write(6,'(a)') trim(chead)
      write(6,*)
      call flush(6)
c
c --- 'idm   ' = output longitudinal array size
c --- 'jdm   ' = output latitudinal  array size
c
      call blkini(idm_out,   'idm   ')
      call blkini(jdm_out,   'jdm   ')
      write(6,*)
      call flush(6)
c
      return
      end subroutine blkdat

      subroutine blkini(ivar,cvar)
      implicit none
c
      integer     ivar
      character*6 cvar
c
c     read in one integer value
c
      character*6 cvarin
c
      read( *,*) ivar,cvarin
      write(6,6000) cvarin,ivar
      call flush(6)
c
      if     (cvar.ne.cvarin) then
        write(6,*)
        write(6,*) 'error in blkini - input ',cvarin,
     +                      ' but should be ',cvar
        write(6,*)
        call flush(6)
        stop
      endif
      return
 6000 format(a6,' =',i6)
      end subroutine blkini

c
c --- user-level routines for napack's cg.
c
      real*8           function ztecnf(x)
      implicit none
c
      real*8           x(2)
c
c     wrapper for ztecmb.
c
      real*8           f,g(2)
c
      call ztecnb(f,g,x)
      ztecnf = f
      return
c     end of ztecnf.
      end
      subroutine ztecng(g,x)
      implicit none
c
      real*8           g(2),x(2)
c
c     wrapper for ztecmb.
c
      real*8           f
c
      call ztecnb(f,g,x)
      return
c     end of ztecng.
      end
      subroutine ztecnp(y,z)
      implicit none
c
      real*8           y(2),z(2)
c
c     null preconditioner
c
      y(1) = z(1)
      y(2) = z(2)
      return
c     end of ztecnp.
      end
      subroutine ztecnb(f,g,x)
cfpp$ noconcur r
      implicit none
c
      real*8         x(2),f,g(2)
c
      logical        ldebug
      real*8         a,b
      common/zaecnb/ a(0:2,0:2),b(0:2,0:2),ldebug
      save  /zaecnb/
c
c**********
c*
c  1) calculates function (f) and its gradient (g) at a point (x).
c
c  2) function defined in [0.,2.]*[0.,2.] via bi-linear fits to
c      a and b (passed via /zaecnb/) with the result abs(a)+abs(b).
c
c     this function is used for compatibility with bi-linear
c      interpolation from array index to lon,lat space.
c
c  3) passed to the minimization routine 'cg'.
c*
c**********
c
      integer ip,jp
      real*8  d1,d2,dx,dy,fx(2),fy(2)
c
c     choose the quadrent.
c
      if     (x(1).ge.1.0) then
        ip = 1
      else
        ip = 0
      endif
      if     (x(2).ge.1.0) then
        jp = 1
      else
        jp = 0
      endif
c
c     f  at  x(1),x(2)
c
      dx = x(1)-ip
      dy = x(2)-jp
      d1 = (1.d0-dx)*(1.d0-dy)*a(ip,  jp  ) +
     &     (1.d0-dx)*      dy *a(ip,  jp+1) +
     &           dx *(1.d0-dy)*a(ip+1,jp  ) +
     &           dx *      dy *a(ip+1,jp+1)
      d2 = (1.d0-dx)*(1.d0-dy)*b(ip,  jp  ) +
     &     (1.d0-dx)*      dy *b(ip,  jp+1) +
     &           dx *(1.d0-dy)*b(ip+1,jp  ) +
     &           dx *      dy *b(ip+1,jp+1)
      f  = sqrt( d1**2 + d2**2 )
c
c     1st derivatives.
c
      dx = x(1)-ip + 0.01
      dy = x(2)-jp
      d1 = (1.d0-dx)*(1.d0-dy)*a(ip,  jp  ) +
     &     (1.d0-dx)*      dy *a(ip,  jp+1) +
     &           dx *(1.d0-dy)*a(ip+1,jp  ) +
     &           dx *      dy *a(ip+1,jp+1)
      d2 = (1.d0-dx)*(1.d0-dy)*b(ip,  jp  ) +
     &     (1.d0-dx)*      dy *b(ip,  jp+1) +
     &           dx *(1.d0-dy)*b(ip+1,jp  ) +
     &           dx *      dy *b(ip+1,jp+1)
      fx(1) = sqrt( d1**2 + d2**2 )
c
      dx = x(1)-ip - 0.01
      dy = x(2)-jp
      d1 = (1.d0-dx)*(1.d0-dy)*a(ip,  jp  ) +
     &     (1.d0-dx)*      dy *a(ip,  jp+1) +
     &           dx *(1.d0-dy)*a(ip+1,jp  ) +
     &           dx *      dy *a(ip+1,jp+1)
      d2 = (1.d0-dx)*(1.d0-dy)*b(ip,  jp  ) +
     &     (1.d0-dx)*      dy *b(ip,  jp+1) +
     &           dx *(1.d0-dy)*b(ip+1,jp  ) +
     &           dx *      dy *b(ip+1,jp+1)
      fx(2) = sqrt( d1**2 + d2**2 )
c
      dx = x(1)-ip
      dy = x(2)-jp + 0.01
      d1 = (1.d0-dx)*(1.d0-dy)*a(ip,  jp  ) +
     &     (1.d0-dx)*      dy *a(ip,  jp+1) +
     &           dx *(1.d0-dy)*a(ip+1,jp  ) +
     &           dx *      dy *a(ip+1,jp+1)
      d2 = (1.d0-dx)*(1.d0-dy)*b(ip,  jp  ) +
     &     (1.d0-dx)*      dy *b(ip,  jp+1) +
     &           dx *(1.d0-dy)*b(ip+1,jp  ) +
     &           dx *      dy *b(ip+1,jp+1)
      fy(1) = sqrt( d1**2 + d2**2 )
c
      dx = x(1)-ip
      dy = x(2)-jp - 0.01
      d1 = (1.d0-dx)*(1.d0-dy)*a(ip,  jp  ) +
     &     (1.d0-dx)*      dy *a(ip,  jp+1) +
     &           dx *(1.d0-dy)*a(ip+1,jp  ) +
     &           dx *      dy *a(ip+1,jp+1)
      d2 = (1.d0-dx)*(1.d0-dy)*b(ip,  jp  ) +
     &     (1.d0-dx)*      dy *b(ip,  jp+1) +
     &           dx *(1.d0-dy)*b(ip+1,jp  ) +
     &           dx *      dy *b(ip+1,jp+1)
      fy(2) = sqrt( d1**2 + d2**2 )
c
      g(1) = (fx(1)-fx(2))/0.02
      g(2) = (fy(1)-fy(2))/0.02
c
*     if     (ldebug) then
*       write(6,*) '***** X,  = ',x(1),x(2)
*       write(6,*) '***** FX  = ',f,fx
*       write(6,*) '***** FY  = ',f,fy
*       write(6,*) '***** F,G = ',f,g(1),g(2)
*       call flush(6)
*     endif
      return
c     end of ztecnb.
      end
c
c      ________________________________________________________
c     |                                                        |
c     |   minimize a function using the fletcher-reeves form   |
c     |            of the conjugate gradient method            |
c     |            with (or without) preconditioning           |
c     |                                                        |
c     |    input:                                              |
c     |                                                        |
c     |         x     --array containing starting guess        |
c     |                                                        |
c     |         step  --starting guess for minimizer in direc- |
c     |                 tion of negative gradient during first |
c     |                 iteration (e. g. step=1) when step=0,  |
c     |                 the program selects a starting guess   |
c     |                                                        |
*     |         t     --computing tolerance (iterations stop   |
*     |                 when max-norm of gradient .le. t)      |
c     |         tt    --computing tolerance (iterations stop   |
c     |                 when function result .le. t)           |
c     |                                                        |
c     |         limit --maximum number of iterations           |
c     |                                                        |
c     |         n     --number of unknowns                     |
c     |                                                        |
c     |         m     --number of iterations until the search  |
c     |                 directions are renormalized along the  |
c     |                 negative gradient (typically, m = n)   |
c     |                                                        |
c     |         value --name of cost evaluation func. routine  |
c     |                 (external in main program)             |
c     |                 value(x) is value of cost at x         |
c     |                                                        |
c     |         grad  --name of gradient evaluation subroutine |
c     |                 (external in main program)             |
c     |                 grad(g,x) puts in g the gradient at x  |
c     |                                                        |
c     |         both  --name subroutine to evaluate both cost  |
c     |                 and its gradient (external in main     |
c     |                 program) both(v,g,x) puts the value in |
c     |                 v and the gradient in g for the point x|
c     |                                                        |
c     |         pre   --name of preconditioning subroutine     |
c     |                 (external in main program)             |
c     |                 pre(y,z) applies the preconditioner to |
c     |                 z, storing the result in y.            |
c     |                 if preconditioning not used set y = z  |
c     |                                                        |
c     |         h     --work array (length at least 3n)        |
c     |                                                        |
c     |    output:                                             |
c     |                                                        |
c     |         x     --minimizer                              |
c     |                                                        |
*     |         e     --max-norm of gradient                   |
c     |         ee    --function result
c     |                                                        |
c     |         it    --number of iterations performed         |
c     |                                                        |
c     |         step  --step size along search direction for   |
c     |                 final iteration                        |
c     |                                                        |
c     |    builtin functions: dabs,dexp,idint,dlog,dsqrt,dmax1,|
c     |                         dmin1,dsign                    |
c     |    package routines: cub,fd,fv,fvd,ins                 |
c     |________________________________________________________|
c
*     subroutine cg(x,e,it,step,t,limit,n,m,value,grad,both,pre,h)
      subroutine cg(x,ee,it,step,tt,limit,n,m,
     &              value,grad,both,pre,h, ldebug)
      implicit none
      logical ldebug
      integer i,iq,it,j,k,l,limit,m,n,na,nb,nc,nd
      real*8 h(n,*),x(*),y(50),z(50),a1,a2,a3,a4,a5,a6,a7,a8,a,b,c,c0,c1
      real*8 d,d0,da,db,e,f,f0,f1,fa,fb,fc,g,l3,p,q,r,s,step,t,v,w
      real*8 tt,ee
      real*8 fv,fd,value
      external both,grad,pre,value
      data a1/.1d0/,a2/.9d0/,a3/5.d0/,a4/.2d0/,a5/10.d0/,a6/.9d0/
      data a7/.3d0/
      a8 = a3 + .01d0
      it = 0
      call both(f,h(1,3),x)
      e = 0.
      do 10 i = 1,n
10         if ( dabs(h(i,3)) .gt. e ) e = dabs(h(i,3))
*     if ( e .le. t ) return
      ee = f
      if (ee .le. tt) return
      l3 = 1./dlog(a3)
      call pre(h(1,2),h(1,3))
      a = step
      if ( a .gt. 0. ) goto 30
      do 20 i = 1,n
20         if ( dabs(x(i)) .gt. a ) a = dabs(x(i))
      a = .01*a/e
      if ( a .eq. 0. ) a = 1.
30    g = 0.
      do 40 i = 1,n
40         g = g + h(i,2)*h(i,3)
      if ( g .lt. 0. ) goto 620
50    l = 0
      do 60 i = 1,n
60         h(i,1) = -h(i,2)
      d = -g
70    fa = fv(a,x,h,n,value)
      c0 = a
      f0 = fa
      j = 2
      y(1) = 0.
      z(1) = f
      y(2) = a
      z(2) = fa
      v = a1*d
      w = a2*d
      iq = 0
      if ( fa .le. f ) goto 80
      c = a
      b = 0.
      a = 0.
      fc = fa
      fb = f
      fa = f
      goto 90
80    c = 0.
      b = 0.
      fc = f
      fb = f
      iq = 1
90    na = 0
      nb = 0
      nc = 0
      nd = 0
      q = (d+(f-f0)/c0)/c0
      if ( q .lt. 0. ) goto 110
      q = a
100   nd = nd + 1
      if ( nd .gt. 25 ) goto 610
      q = a3*q
      p = fv(q,x,h,n,value)
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      if ( p-f .lt. w*q ) goto 100
      goto 260
110   q = .5*d/q
      if ( q .lt. .01*c0 ) q = .01*c0
      p = fv(q,x,h,n,value)
      if ( p .le. f0 ) goto 120
      f1 = f0
      c1 = c0
      f0 = p
      c0 = q
      goto 130
120   f1 = p
      c1 = q
130   call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
135   if ( a .eq. 0. ) goto 140
      if ( fa-f .ge. v*a ) goto 160
      if ( fa-f .lt. w*a ) goto 210
      goto 280
140   q = c0
      if ( c1 .lt. q ) q = c1
150   na = na + 1
      if ( na .gt. 25 ) goto 630
      q = a4*q
      p = fv(q,x,h,n,value)
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      if ( p-f .ge. v*q ) goto 150
      goto 250
160   if ( c0 .gt. c1 ) goto 200
      if ( f0-f .gt. v*c0 ) goto 180
      if ( f0-f .ge. w*c0 ) goto 320
      if ( c1 .le. a5*c0 ) goto 320
      r = dlog(c1/c0)
      s = -idint(r*l3+.999)
      r = .999*dexp(r/s)
      q = c1
170   q = q*r
      if ( q .lt. c0 ) goto 320
      p = fv(q,x,h,n,value)
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      na = na + 1
      if ( na .gt. 25 ) goto 630
      if ( p-f .gt. v*q ) goto 170
      goto 320
180   q = c0
190   na = na + 1
      if ( na .gt. 25 ) goto 630
      q = a4*q
      p = fv(q,x,h,n,value)
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      if ( p-f .ge. v*q ) goto 190
      goto 250
200   q = a
      goto 190
210   if ( c0 .lt. c1 ) goto 290
      if ( f0-f .ge. v*c0 ) goto 230
      if ( f0-f .ge. w*c0 ) goto 250
      q = c0
220   nd = nd  + 1
      if ( nd .gt. 25 ) goto 610
      q = a3*q
      p = fv(q,x,h,n,value)
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      if ( p-f .lt. w*q ) goto 220
      goto 250
230   if ( c0 .le. a5*c1 ) goto 250
      r = dlog(c0/c1)
      s = idint(r*l3+.999)
      r = 1.001*dexp(r/s)
      q = a
240   q = q*r
      if ( q .gt. c0 ) goto 250
      nd = nd + 1
      p = fv(q,x,h,n,value)
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      if ( p-f .lt. w*q ) goto 240
250   if ( iq .eq. 1 ) goto 320
260   if ( b .eq. 0. ) goto 280
      if ( c .eq. 0. ) goto 270
      v = c - a
      w = a - b
      r = 1./v
      s = 1./w
      p = fc - fa
      q = fb - fa
      e = p*r + q*s
      if ( dsign(e,c-b) .ne. e ) goto 320
      if ( e .eq. 0. ) goto 320
      q = (p*r)*w - (q*s)*v
      q = a - .5*q/e
      p = fv(q,x,h,n,value)
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      goto 320
270   r = 1./a
      s = 1./b
      p = r*(fa-f) - d
      q = s*(fb-f) - d
      e = a - b
      v = (r*p-s*q)/e
      w = (a*q*s-b*p*r)/e
      v = w*w-3.*v*d
      if ( v .lt. 0. ) v = 0.
      v = dsqrt(v)
      if ( w+v .eq. 0. ) goto 320
      q = -d/(w+v)
      if ( q .le. 0. ) goto 320
      p = fv(q,x,h,n,value)
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      goto 320
280   if ( iq .eq. 1 ) goto  320
      q = (d+(f-fa)/a)/a
      if ( q .ge. 0. ) goto 320
      q = .5*d/q
      p = fv(q,x,h,n,value)
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      goto 320
290   if ( f0-f .gt. v*c0 ) goto 300
      if ( f0-f .gt. w*c0 ) goto 320
300   q = a
310   nd = nd + 1
      if ( nd .gt. 25 ) goto 610
      q = a3*q
      p = fv(q,x,h,n,value)
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      if ( p-f .lt. w*q ) goto 310
      goto 250
320   da = fd(a,x,h,n,grad)
      if ( da .gt. a6*g ) goto 410
      if ( da .ge. 0. ) goto 560
      r = a
      q = 0.
      do 330 i = 1,j
           if ( y(i) .gt. a ) goto 370
           if ( y(i) .le. q ) goto 330
           if ( y(i) .eq. a ) goto 330
           q = y(i)
330   continue
      if ( a .le. a8*q ) goto 560
      q = a
340   nd = nd + 1
      if ( nd .gt. 25 ) goto 610
      q = a3*q
      p = fv(q,x,h,n,value)
      f1 = fa
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      if ( p .lt. f1 ) goto 340
      if ( a .gt. r ) goto 360
      do 350 i = 1,n
350        h(i,2) = x(i) + a*h(i,1)
      goto 560
360   da = fd(a,x,h,n,grad)
      if ( da .gt. a6*g ) goto 410
      goto 560
370   q = y(i)
      do 380 k = i,j
           if ( y(k) .le. a ) goto 380
           if ( y(k) .lt. q ) q = y(k)
380   continue
      if ( q .le. a5*a ) goto 560
      f0 = dlog(q/a)
      s = idint(f0*l3+.999)
      f0 = 1.001*dexp(f0/s)
      s = a
390   s = s*f0
      if ( s .ge. q ) goto 320
      p = fv(s,x,h,n,value)
      f1 = fa
      call ins(s,p,a,b,c,fa,fb,fc,j,y,z)
      if ( p .lt. f1 ) goto 390
      if ( a .gt. r ) goto 320
      do 400 i = 1,n
400        h(i,2) = x(i) + a*h(i,1)
      goto 560
410   b = 0.
      k = 1
      i = k
420   i = i + 1
      if ( i .gt. j ) goto 430
      if ( y(i) .ge. a ) goto 420
      if ( y(i) .lt. b ) goto 420
      b = y(i)
      k = i
      goto 420
430   fb = z(k)
      db = d
      if ( b .ne. 0. ) db = fd(b,x,h,n,grad)
440   w = 2.*dabs(b-a)
      call cub(c,a,b,fa,fb,da,db)
      nc = 1
      goto 480
450   w = .5*w
      if ( w .lt. dabs(c0-c) ) goto 550
      if ( c0 .lt. c ) goto 460
      if ( d0 .ge. d ) goto 470
      goto 550
460   if ( d0 .gt. d ) goto 550
470   call cub(c,c,c0,f,f0,d,d0)
      nc = nc + 1
      if ( nc .gt. 30 ) goto 600
480   r = dmax1(a,b)
      s = dmin1(a,b)
      if ( c .gt. r ) goto 490
      if ( c .gt. s ) goto 500
      c = s + (s-c)
      s = .5*(a+b)
      if ( c .gt. s ) c = s
      goto 500
490   c = r - (c-r)
      s = .5*(a+b)
      if ( c .lt. s ) c = s
500   c0 = a
      f0 = fa
      d0 = da
      call fvd(f,d,c,x,h,n,both)
      if ( f .lt. fa ) goto 510
      b = c
      fb = f
      db = d
      goto 450
510   if ( c .lt. a ) goto 540
      if ( d .lt. 0. ) goto 530
520   b = a
      fb = fa
      db = da
530   a = c
      fa = f
      da = d
      if ( d .gt. a6*g ) goto 450
      goto 560
540   if ( d .lt. 0. ) goto 520
      goto 530
550   c = .5*(a+b)
      nb = nb + 1
      w = dabs(b-a)
      goto 500
560   e = 0.
      do 570 i = 1,n
           if ( dabs(h(i,3)) .gt. e ) e = dabs(h(i,3))
570        x(i) = h(i,2)
      it = it + 1
*     if ( e .le. t ) goto 660
      ee = f
      if     (ldebug) then
        write(6,'(a,i4,1pg20.10)')
     &    'cg - it,ee =',it,ee
        call flush(6)
      endif
      if ( ee .le. tt ) goto 660
      if ( it .ge. limit ) goto 660
      f = fa
      d = da
      a = a7*a
      call pre(h(1,2),h(1,3))
      r = 0.
      do 580 i = 1,n
580        r = r + h(i,2)*h(i,3)
      if ( r .lt. 0. ) goto 620
      s = r/g
      g = r
      l = l + 1
      if ( l .ge. m ) goto 50
      d = 0.
      do 590 i = 1,n
           h(i,1) = -h(i,2) + s*h(i,1)
590        d = d + h(i,1)*h(i,3)
      goto 70
600   if ( d .lt. g ) goto 560
        if     (ldebug) then
          write(6,*) 'UNABLE TO OBTAIN DESCENT DIRECTION'
        endif
*       stop
        it = -1
        return
610   continue
        if     (ldebug) then
          write(6,*) 'THE FUNCTION DECREASES WITH NO MINIMUM'
        endif
*       stop
        it = -1
        return
620   continue
        if     (ldebug) then
          write(6,*) 'PRECONDITIONER NOT POSITIVE DEFINITE'
        endif
*       stop
        it = -1
        return
630   continue
      q = q*a3**25
      nd = 0
640   nd = nd + 1
      if ( nd .gt. 25 ) goto 650
      q = a3*q
      p = fv(q,x,h,n,value)
      call ins(q,p,a,b,c,fa,fb,fc,j,y,z)
      if ( p-f .gt. v*q ) goto 640
      goto 135
650   continue
        if     (ldebug) then
          write(6,*) 'UNABLE TO SATISFY ARMIJO CONDITION'
        endif
        it = -1
        return
660   continue
      step = a
      return
      end
      real*8 function fv(a,x,h,n,value)
      real*8 h(n,*),x(*),a,value
      external value
      do 10 i = 1 , n
10         h(i,2) = x(i) + a*h(i,1)
      fv = value(h(1,2))
      return
      end
      real*8 function fd(a,x,h,n,grad)
      real*8 h(n,*),x(*),a,d
      external grad
      do 10 i = 1 , n
10         h(i,2) = x(i) + a*h(i,1)
      call grad(h(1,3),h(1,2))
      d = 0.
      do 20 i = 1,n
20         d = d + h(i,1)*h(i,3)
      fd = d
      return
      end
      subroutine fvd(v,d,a,x,h,n,both)
      implicit none
      integer  n
      real*8   h(n,*),x(*),a,d,v
      external both
      integer  i
      do 10 i = 1 , n
10         h(i,2) = x(i) + a*h(i,1)
      call both(v,h(1,3),h(1,2))
      d = 0.
      do 20 i = 1,n
20         d = d + h(i,1)*h(i,3)
      return
      end
      subroutine cub(x,a,b,c,d,e,f)
      implicit none
      real*8 a,b,c,d,e,f,g,v,w,x,y,z
      g = b - a
      if ( g .eq. 0. ) goto 50
      v = e + f - 3*(d-c)/g
      w = v*v-e*f
      if ( w .lt. 0. ) w = 0.
      w = dsign(dsqrt(w),g)
      y = e + v
      z = f + v
      if ( dsign(y,g) .ne. y ) goto 30
      if ( dsign(z,g) .ne. z ) goto 20
      if ( z .eq. 0. ) goto 20
10    x = b - g*f/(z+w)
      return
20    if ( c .lt. d ) x = a
      if ( c .ge. d ) x = b
      return
30    if ( dsign(z,g) .ne. z ) goto 40
      if ( dabs(e) .gt. dabs(f) ) goto 10
40    x = a + g*e/(y-w)
      return
50    x = a
      return
      end
      subroutine ins(s,f,a,b,c,fa,fb,fc,j,y,z)
      implicit none
      real*8 a,b,c,f,fa,fb,fc,s,y(*),z(*)
      integer j
      j = j + 1
      y(j) = s
      z(j) = f
      if ( f .le. fa ) goto 20
      if ( f .le. fb ) goto 10
      if ( f .gt. fc ) return
      c = s
      fc = f
      return
10    c = b
      b = s
      fc = fb
      fb = f
      return
20    c = b
      b = a
      a = s
      fc = fb
      fb = fa
      fa = f
      return
      end


      SUBROUTINE b_error_mode (m)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE stel_constants
      USE boundary
      USE bnorm_mod
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------

      INTEGER :: ku, kv, n, m, mn
      REAL(rprec) :: sinmn
!-----------------------------------------------

      OPEN (unit=33,file='bmnerr.dat',status='unknown')

      mn = m

      bmn_error(:) = zero
      n = 0
      DO ku = 1, nu
         DO kv = 1, nv
            n = n + 1
            sinmn = SIN (xm_bmn(mn)*(thetab(n) + luv(n))
     1            - xn_bmn(mn)*phib(n))
            bmn_error(n) = bmn(mn)*sinmn
            WRITE (33,100) nfp*phib(n)/twopi, thetab(n)/twopi,
     1         bmn_error(n)
         END DO
         WRITE (33,110)
      END DO

  100 FORMAT (1p,3e15.6)
  110 FORMAT ("")
      CLOSE (33)

      END SUBROUTINE b_error_mode


      subroutine PVEC (LIST,HEAD)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 PVEC  Krogh   Declared all vars.
c>> 1990-02-08 PVEC WV Snyder at JPL 91109, adapted for MATH77
c
c     PVEC converts a chain of items in LIST, starting at HEAD, to a
c     permutation vector.
c
      integer LIST(*),HEAD
      integer I, J, N, K
      n=0
      i=head
c
c     Convert the chain in LIST to an inverse permutation vector.
c
    1 if (i.ne.0) then
         n=n+1
         j=list(i)
         list(i)=n
         i=j
         go to 1
      end if
c
c     Invert the inverse permutation vector in LIST.
c
    2 if (n.eq.0) return
      j=n
      k=list(j)
      if (k.ne.n) then
    3    i=list(j)
         if (i.gt.0) then
            list(j)=-k
            k=j
            j=i
            if (j.ne.n) go to 3
            list(n)=k
         else
            list(j)=-i
         end if
      end if
      n=n-1
      go to 2
      end


logical function appr(x,y)
real(8) :: x,y
if(abs(x-y) < 1.d-6*abs(x)) then
    appr = .true.
else
    appr = .false.
end if
end function

subroutine check_double(x,y)
real(8) :: x,y
if(.not. appr(x,y)) then
    write(*,'(G16.7,"/=",G16.7)') x,y
    stop 1
end if
end subroutine


module KindModule

  implicit none

  public

  integer, parameter :: DP = KIND(1.0D0)                                         ! Precision of all real variables
  integer, parameter :: LGP = SELECTED_INT_KIND(8)                               ! Logical kind
  integer, parameter :: I4B = SELECTED_INT_KIND(8)                               ! Integer kind
  integer, parameter :: I8B = SELECTED_INT_KIND(18)                              ! Long integer kind

  contains

  subroutine write_kindinfo(iout)
! ******************************************************************************
! write_kindinfo -- write out information about the kind variables
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    integer(I4B), intent(in) :: iout
    integer(LGP) :: ldum = 0
    integer(I4B) :: idum = 0
    integer(I8B) :: long_idum = 0
    integer(DP) :: irdum = 0 ! for bit size of real variables
    real(DP) :: rdum = 0._DP
! ------------------------------------------------------------------------------
    !
    write(iout, '(/a)') 'Real Variables'
    write(iout, '(2x,a,i0)') 'KIND: ', DP
    write(iout, '(2x,a,1pg15.6)') 'TINY (smallest non-zero value): ', tiny(rdum)
    write(iout, '(2x,a,1pg15.6)') 'HUGE (largest value): ', huge(rdum)
    write(iout, '(2x,a,i0)') 'PRECISION: ', precision(rdum)
    write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(irdum)

    write(iout, '(/a)') 'Integer Variables'
    write(iout, '(2x,a,i0)') 'KIND: ', I4B
    write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(idum)
    write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(idum)

    write(iout, '(/a)') 'Long Integer Variables'
    write(iout, '(2x,a,i0)') 'KIND: ', I8B
    write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(long_idum)
    write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(long_idum)

    write(iout, '(/a)') 'Logical Variables'
    write(iout, '(2x,a,i0)') 'KIND: ', LGP
    write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(ldum)
    !
    ! -- Return
    return
  end subroutine write_kindinfo

end module KindModule


use plantfem

implicit none

type(Preprocessing_) :: root,soil
type(FEMDomain_) :: domain
type(MPI_) :: mpid
character(10) :: name
character(10) :: project = "soil"
character(20) :: ElemType = "LinearRectangularGp4"
character(10) :: str_id = "1"

call mpid%start()

! in this picture,
! root color is (R:0, G:255,B:255)
! and soil color is (R:0, G:0,B:0)
name = "test.png"

! Get RGB value of root
call root%ImportPictureName(name)
call root%GetPixcelSize(mpid)
call root%SetColor(0,255,255)
call root%GetPixcelByRGB(mpid,err=5,onlycoord=.true.)

! Get Outline of root
call root%GetSurfaceNode(mpid)
call root%AssembleSurfaceElement(mpid,dim=2,threshold=5,DelRange=5)

!<<< CAUTION! please check GetSurface_pid_***.txt>>>

!<<< CAUTION! If you want to use 4-node element, gmsh>tool>option>mesh>general
!    then check "recombine elements", and set option as default.>>>
! Convert SurfaceNod to .geo
call root%ExportGeoFile(mpid,Name=trim(project)//"mesh"//trim(str_id)//".geo" )

! Run Gmsh to convert .geo to .msh
call root%ConvertGeo2Msh(mpid, Name=trim(project)//"mesh"//trim(str_id)//".geo" )
call root%ConvertGeo2Inp(mpid, Name=trim(project)//"mesh"//trim(str_id)//".geo" )
call root%ConvertGeo2Mesh(mpid,Name=trim(project)//"mesh"//trim(str_id)//".geo" )

call root%ConvertMesh2Scf(mpid,ElementType=ElemType,&
     Name=trim(project)//"mesh"//trim(str_id)//".mesh" )
call root%FEMDomain%checkconnectivity(fix=.true.)

! create soil mesh

call soil%ImportPictureName(name)
call soil%GetPixcelSize(mpid)
call soil%SetColor(0,0,0)
call soil%GetPixcelByRGB(mpid,err=5,onlycoord=.true.)

! Get Outline (simple outline)
! see soil as a box
call soil%GetSurfaceNode(mpid,box=.true.)
call soil%modifySuefaceNode(Mesh=root%FEMDomain%Mesh,boolean="diff")

! Convert SurfaceNod to .geo
call soil%ExportGeoFile(mpid,Name=trim(project)//"soil"//trim(str_id)//".geo" )

! Run Gmsh to convert .geo to .msh
call soil%ConvertGeo2Msh(mpid ,Name=trim(project)//"soil"//trim(str_id)//".geo" )
call soil%ConvertGeo2Inp(mpid ,Name=trim(project)//"soil"//trim(str_id)//".geo" )
call soil%ConvertGeo2Mesh(mpid,Name=trim(project)//"soil"//trim(str_id)//".geo" )

call mpid%end()

end


c
c***************************************************************************
c
      subroutine invert(rho_in, theta_in, capr_out, capz_out,
     . nnodex, nnodey, nxmx, nymx, rho, theta, capr, capz, myid,
     . drhodr, drhodz, dthedr, dthedz, xj)

      implicit none
      integer myid, nnodex, nnodey, nxmx, nymx, n, m, nmin, mmin
      real rho_in, theta_in, capr_out, capz_out, diff_rho, diff_theta,
     .   diff, diffmin
      real  capr(nxmx), capz(nymx), rk, zk,
     .     rho(nxmx, nymx), theta(nxmx, nymx),
     .  drhodr(nxmx, nymx), drhodz(nxmx, nymx),
     .  dthedr(nxmx, nymx), dthedz(nxmx, nymx)
      real  xj, thetak, rhok, dthedrk, drhodzk, drhodrk, dthedzk

      diffmin = 1.0

      do n = 1, nnodex
         do m = 1, nnodey
	    diff_rho = rho_in - rho(n,m)
	    diff_theta = theta_in - theta(n,m)
	    diff = sqrt(diff_rho**2 + diff_theta**2)

	    if(diff .le. diffmin)then
	       diffmin = diff
	       nmin = n
	       mmin = m
	    end if

	 end do
      end do

      n = nmin
      m = mmin

      rk = capr(n)
      zk = capz(m)
      rhok = rho(n,m)
      thetak = theta(n,m)
      drhodrk = drhodr(n,m)
      drhodzk = drhodz(n,m)
      dthedrk = dthedr(n,m)
      dthedzk = dthedz(n,m)

      xj = dthedrk * drhodzk - drhodrk * dthedzk

      if(xj .eq. 0)then
         capr_out = rk
	 capz_out = zk
	 return
      end if

      capr_out = rk + 1. / xj * (drhodzk * (theta_in - thetak)
     .                         - dthedzk * (rho_in   - rhok)  )
      capz_out = zk + 1. / xj * (dthedrk * (rho_in   - rhok)
     .                         - drhodrk * (theta_in - thetak))

      return
      end

c
c***************************************************************************
c
      subroutine checkx(myid, i, j, nkx1, nkx2, nky1, nky2,
     1   fdk, fek, ffk, u, v, w,
     1   xb, xc, xd, nkdim1, nkdim2, mkdim1, mkdim2,
     1   nnodex, nnodey, nxmx, nymx, xprime, yprime,
     1   idiag, jdiag, isweep)

      implicit none

      integer nkx1, nkx2, nky1, nky2, nkdim1, nkdim2, mkdim1, mkdim2,
     1        nnodex, nnodey, nxmx, nymx, idiag, jdiag, isweep,
     1        i, j, n, m, myid

      complex fdk(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        fek(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        ffk(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        xb(nxmx, nymx), term1,
     1        xc(nxmx, nymx), term2,
     1        xd(nxmx, nymx), term3,
     1        xlhs, xrhs
      complex u(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        v(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        w(nkdim1 : nkdim2, mkdim1 : mkdim2)

      real    xprime(nxmx), yprime(nymx)

      if (myid .eq. 0) then
         write(15, 910)
         write(15, 930)
         write(15, 920)
         write(15, 940)
         write(15, 920)

         write(6, 910)
         write(6, 930)
         write(6, 920)
         write(6, 940)
         write(6, 920)

         term1 = 0.0
         term2 = 0.0
         term3 = 0.0

         do n = nkx1, nkx2
            do m = nky1, nky2

            term1 = term1 + fdk(n, m) * u(n, m)
            term2 = term2 + fek(n, m) * v(n, m)
            term3 = term3 + ffk(n, m) * w(n, m)

            end do
         end do

         xlhs = term1 + term2 + term3
         xrhs = xb(i, j)
         write(15, 900) i, j, xprime(i), yprime(j), xlhs, xrhs
         write(6,  900) i, j, xprime(i), yprime(j), xlhs, xrhs

	 write(15, 901) term1, term2, term3
         write(6,  901) term1, term2, term3

	 write(15, 901) u(64,64), v(64,64), w(64,64)
         write(6,  901) u(64,64), v(64,64), w(64,64)

	 write(15, 901) fdk(64,64), fek(64,64), ffk(64,64)
         write(6,  901) fdk(64,64), fek(64,64), ffk(64,64)

      endif

      return
  900 format(i5, i5, 1p9e12.3)
  901 format(10x, 1p9e12.3)
  940 format(1h , 4h   i, 5h    j, 4x, 6h x(i) , 6x, 6h y(j) ,
     1                    6x,  6hre lhs, 6x, 6him lhs, 6x,
     1                         6hre rhs, 6x, 6him rhs)
  910 format (1h1)
  920 format (1h0)
  930 format(3x, 14h u diagnostics)
      end

c
c***************************************************************************
c
      subroutine checky(myid, i, j, nkx1, nkx2, nky1, nky2,
     1   fgk, fak, fpk, u, v, w,
     1   xb, xc, xd, nkdim1, nkdim2, mkdim1, mkdim2,
     1   nnodex, nnodey, nxmx, nymx, xprime, yprime,
     1   idiag, jdiag, isweep)

      implicit none

      integer nkx1, nkx2, nky1, nky2, nkdim1, nkdim2, mkdim1, mkdim2,
     1        nnodex, nnodey, nxmx, nymx, idiag, jdiag, isweep,
     1        i, j, n, m, myid

      complex fgk(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        fak(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        fpk(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        xb(nxmx, nymx), term1,
     1        xc(nxmx, nymx), term2,
     1        xd(nxmx, nymx), term3,
     1        xlhs, xrhs
      complex u(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        v(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        w(nkdim1 : nkdim2, mkdim1 : mkdim2)

      real    xprime(nxmx), yprime(nymx)

      if (myid .eq. 0) then
         write(15, 910)
         write(15, 930)
         write(15, 920)
         write(15, 940)
         write(15, 920)

         write(6, 910)
         write(6, 930)
         write(6, 920)
         write(6, 940)
         write(6, 920)

         term1 = 0.0
         term2 = 0.0
         term3 = 0.0

         do n = nkx1, nkx2
            do m = nky1, nky2

            term1 = term1 + fgk(n, m) * u(n, m)
            term2 = term2 + fak(n, m) * v(n, m)
            term3 = term3 + fpk(n, m) * w(n, m)

            end do
         end do

         xlhs = term1 + term2 + term3
         xrhs = xc(i, j)
         write(15, 900) i, j, xprime(i), yprime(j), xlhs, xrhs
         write(6,  900) i, j, xprime(i), yprime(j), xlhs, xrhs

         write(15, 901) term1, term2, term3
         write(6,  901) term1, term2, term3

	 write(15, 901) u(64,64), v(64,64), w(64,64)
         write(6,  901) u(64,64), v(64,64), w(64,64)

	 write(15, 901) fgk(64,64), fak(64,64), fpk(64,64)
         write(6,  901) fgk(64,64), fak(64,64), fpk(64,64)
      endif

      return
  900 format(i5, i5, 1p9e12.3)
  901 format(10x, 1p9e12.3)
  940 format(1h , 4h   i, 5h    j, 4x, 6h x(i) , 6x, 6h y(j) ,
     1                    6x,  6hre lhs, 6x, 6him lhs, 6x,
     1                         6hre rhs, 6x, 6him rhs)
  910 format (1h1)
  920 format (1h0)
  930 format(3x, 14h v diagnostics)
      end

c
c***************************************************************************
c
      subroutine checkz(myid, i, j, nkx1, nkx2, nky1, nky2,
     1   frk, fqk, fsk, u, v, w,
     1   xb, xc, xd, nkdim1, nkdim2, mkdim1, mkdim2,
     1   nnodex, nnodey, nxmx, nymx, xprime, yprime,
     1   idiag, jdiag, isweep)

      implicit none

      integer nkx1, nkx2, nky1, nky2, nkdim1, nkdim2, mkdim1, mkdim2,
     1        nnodex, nnodey, nxmx, nymx, idiag, jdiag, isweep,
     1        i, j, n, m, myid

      complex frk(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        fqk(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        fsk(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        xb(nxmx, nymx), term1,
     1        xc(nxmx, nymx), term2,
     1        xd(nxmx, nymx), term3,
     1        xlhs, xrhs
      complex u(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        v(nkdim1 : nkdim2, mkdim1 : mkdim2),
     1        w(nkdim1 : nkdim2, mkdim1 : mkdim2)

      real    xprime(nxmx), yprime(nymx)

      if (myid .eq. 0) then
         write(15, 910)
         write(15, 930)
         write(15, 920)
         write(15, 940)
         write(15, 920)

         write(6, 910)
         write(6, 930)
         write(6, 920)
         write(6, 940)
         write(6, 920)

         term1 = 0.0
         term2 = 0.0
         term3 = 0.0

         do n = nkx1, nkx2
            do m = nky1, nky2

            term1 = term1 + frk(n, m) * u(n, m)
            term2 = term2 + fqk(n, m) * v(n, m)
            term3 = term3 + fsk(n, m) * w(n, m)

            end do
         end do

         xlhs = term1 + term2 + term3
         xrhs = xd(i, j)
         write(15, 900) i, j, xprime(i), yprime(j), xlhs, xrhs
         write(6,  900) i, j, xprime(i), yprime(j), xlhs, xrhs

	 write(15, 901) term1, term2, term3
         write(6,  901) term1, term2, term3

	 write(15, 901) u(64,64), v(64,64), w(64,64)
         write(6,  901) u(64,64), v(64,64), w(64,64)

	 write(15, 901) frk(64,64), fqk(64,64), fsk(64,64)
         write(6,  901) frk(64,64), fqk(64,64), fsk(64,64)

      endif

      return
  900 format(i5, i5, 1p9e12.3)
  901 format(10x, 1p9e12.3)
  940 format(1h , 4h   i, 5h    j, 4x, 6h x(i) , 6x, 6h y(j) ,
     1                    6x,  6hre lhs, 6x, 6him lhs, 6x,
     1                         6hre rhs, 6x, 6him rhs)
  910 format (1h1)
  920 format (1h0)
  930 format(3x, 14h w diagnostics)
      end

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


      SUBROUTINE HFTI(A,MDA,M,N,B,MDB,NB,TAU,KRANK,RNORM,H,G,IP)

C     RANK-DEFICIENT LEAST SQUARES ALGORITHM AS DESCRIBED IN:
C     C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY, 1973 JUN 12
C     TO APPEAR IN 'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974

C     A(*,*),MDA,M,N   THE ARRAY A INITIALLY CONTAINS THE M x N MATRIX A
C                      OF THE LEAST SQUARES PROBLEM AX = B.
C                      THE FIRST DIMENSIONING PARAMETER MDA MUST SATISFY
C                      MDA >= M. EITHER M >= N OR M < N IS PERMITTED.
C                      THERE IS NO RESTRICTION ON THE RANK OF A.
C                      THE MATRIX A WILL BE MODIFIED BY THE SUBROUTINE.
C     B(*,*),MDB,NB    IF NB = 0 THE SUBROUTINE WILL MAKE NO REFERENCE
C                      TO THE ARRAY B. IF NB > 0 THE ARRAY B() MUST
C                      INITIALLY CONTAIN THE M x NB MATRIX B  OF THE
C                      THE LEAST SQUARES PROBLEM AX = B AND ON RETURN
C                      THE ARRAY B() WILL CONTAIN THE N x NB SOLUTION X.
C                      IF NB>1 THE ARRAY B() MUST BE DOUBLE SUBSCRIPTED
C                      WITH FIRST DIMENSIONING PARAMETER MDB>=MAX(M,N),
C                      IF NB=1 THE ARRAY B() MAY BE EITHER SINGLE OR
C                      DOUBLE SUBSCRIPTED.
C     TAU              ABSOLUTE TOLERANCE PARAMETER FOR PSEUDORANK
C                      DETERMINATION, PROVIDED BY THE USER.
C     KRANK            PSEUDORANK OF A, SET BY THE SUBROUTINE.
C     RNORM            ON EXIT, RNORM(J) WILL CONTAIN THE EUCLIDIAN
C                      NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM
C                      DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY B.
C     H(), G()         ARRAYS OF WORKING SPACE OF LENGTH >= N.
C     IP()             INTEGER ARRAY OF WORKING SPACE OF LENGTH >= N
C                      RECORDING PERMUTATION INDICES OF COLUMN VECTORS

      INTEGER          I,J,JB,K,KP1,KRANK,L,LDIAG,LMAX,M,
     .                 MDA,MDB,N,NB,IP(N)
      DOUBLE PRECISION A(MDA,N),B(MDB,NB),H(N),G(N),RNORM(NB),FACTOR,
     .                 TAU,ZERO,HMAX,DIFF,TMP,DDOT,DNRM2,U,V
      DIFF(U,V)=       U-V
      DATA             ZERO/0.0D0/, FACTOR/1.0D-3/

      K=0
      LDIAG=MIN(M,N)
      IF(LDIAG.LE.0)                  GOTO 270

C   COMPUTE LMAX

      DO 80 J=1,LDIAG
          IF(J.EQ.1)                  GOTO 20
          LMAX=J
          DO 10 L=J,N
              H(L)=H(L)-A(J-1,L)**2
   10         IF(H(L).GT.H(LMAX)) LMAX=L
          IF(DIFF(HMAX+FACTOR*H(LMAX),HMAX).GT.ZERO)
     .                                GOTO 50
   20     LMAX=J
          DO 40 L=J,N
              H(L)=ZERO
              DO 30 I=J,M
   30             H(L)=H(L)+A(I,L)**2
   40         IF(H(L).GT.H(LMAX)) LMAX=L
          HMAX=H(LMAX)

C   COLUMN INTERCHANGES IF NEEDED

   50     IP(J)=LMAX
          IF(IP(J).EQ.J)              GOTO 70
          DO 60 I=1,M
              TMP=A(I,J)
              A(I,J)=A(I,LMAX)
   60         A(I,LMAX)=TMP
          H(LMAX)=H(J)

C   J-TH TRANSFORMATION AND APPLICATION TO A AND B

   70     I=MIN(J+1,N)
          CALL H12(1,J,J+1,M,A(1,J),1,H(J),A(1,I),1,MDA,N-J)
   80     CALL H12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB)

C   DETERMINE PSEUDORANK

      DO 90 J=1,LDIAG
   90     IF(ABS(A(J,J)).LE.TAU)      GOTO 100
      K=LDIAG
      GOTO 110
  100 K=J-1
  110 KP1=K+1

C   NORM OF RESIDUALS

      DO 130 JB=1,NB
  130     RNORM(JB)=DNRM2(M-K,B(KP1,JB),1)
      IF(K.GT.0)                      GOTO 160
      DO 150 JB=1,NB
          DO 150 I=1,N
  150         B(I,JB)=ZERO
      GOTO 270
  160 IF(K.EQ.N)                      GOTO 180

C   HOUSEHOLDER DECOMPOSITION OF FIRST K ROWS

      DO 170 I=K,1,-1
  170     CALL H12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1)
  180 DO 250 JB=1,NB

C   SOLVE K*K TRIANGULAR SYSTEM

          DO 210 I=K,1,-1
              J=MIN(I+1,N)
  210         B(I,JB)=(B(I,JB)-DDOT(K-I,A(I,J),MDA,B(J,JB),1))/A(I,I)

C   COMPLETE SOLUTION VECTOR

          IF(K.EQ.N)                  GOTO 240
          DO 220 J=KP1,N
  220         B(J,JB)=ZERO
          DO 230 I=1,K
  230         CALL H12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1)

C   REORDER SOLUTION ACCORDING TO PREVIOUS COLUMN INTERCHANGES

  240     DO 250 J=LDIAG,1,-1
              IF(IP(J).EQ.J)          GOTO 250
              L=IP(J)
              TMP=B(L,JB)
              B(L,JB)=B(J,JB)
              B(J,JB)=TMP
  250 CONTINUE
  270 KRANK=K
      END


*DECK CDRV
      subroutine cdrv
     *     (n, r,c,ic, ia,ja,a, b, z, nsp,isp,rsp,esp, path, flag)
c*** subroutine cdrv
c*** driver for subroutines for solving sparse nonsymmetric systems of
c       linear equations (compressed pointer storage)
c
c
c    parameters
c    class abbreviations are--
c       n - integer variable
c       f - real variable
c       v - supplies a value to the driver
c       r - returns a result from the driver
c       i - used internally by the driver
c       a - array
c
c class - parameter
c ------+----------
c       -
c         the nonzero entries of the coefficient matrix m are stored
c    row-by-row in the array a.  to identify the individual nonzero
c    entries in each row, we need to know in which column each entry
c    lies.  the column indices which correspond to the nonzero entries
c    of m are stored in the array ja.  i.e., if  a(k) = m(i,j),  then
c    ja(k) = j.  in addition, we need to know where each row starts and
c    how long it is.  the index positions in ja and a where the rows of
c    m begin are stored in the array ia.  i.e., if m(i,j) is the first
c    nonzero entry (stored) in the i-th row and a(k) = m(i,j),  then
c    ia(i) = k.  moreover, the index in ja and a of the first location
c    following the last element in the last row is stored in ia(n+1).
c    thus, the number of entries in the i-th row is given by
c    ia(i+1) - ia(i),  the nonzero entries of the i-th row are stored
c    consecutively in
c            a(ia(i)),  a(ia(i)+1),  ..., a(ia(i+1)-1),
c    and the corresponding column indices are stored consecutively in
c            ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1).
c    for example, the 5 by 5 matrix
c                ( 1. 0. 2. 0. 0.)
c                ( 0. 3. 0. 0. 0.)
c            m = ( 0. 4. 5. 6. 0.)
c                ( 0. 0. 0. 7. 0.)
c                ( 0. 0. 0. 8. 9.)
c    would be stored as
c               - 1  2  3  4  5  6  7  8  9
c            ---+--------------------------
c            ia - 1  3  4  7  8 10
c            ja - 1  3  2  2  3  4  4  4  5
c             a - 1. 2. 3. 4. 5. 6. 7. 8. 9.         .
c
c nv    - n     - number of variables/equations.
c fva   - a     - nonzero entries of the coefficient matrix m, stored
c       -           by rows.
c       -           size = number of nonzero entries in m.
c nva   - ia    - pointers to delimit the rows in a.
c       -           size = n+1.
c nva   - ja    - column numbers corresponding to the elements of a.
c       -           size = size of a.
c fva   - b     - right-hand side b.  b and z can the same array.
c       -           size = n.
c fra   - z     - solution x.  b and z can be the same array.
c       -           size = n.
c
c         the rows and columns of the original matrix m can be
c    reordered (e.g., to reduce fillin or ensure numerical stability)
c    before calling the driver.  if no reordering is done, then set
c    r(i) = c(i) = ic(i) = i  for i=1,...,n.  the solution z is returned
c    in the original order.
c         if the columns have been reordered (i.e.,  c(i).ne.i  for some
c    i), then the driver will call a subroutine (nroc) which rearranges
c    each row of ja and a, leaving the rows in the original order, but
c    placing the elements of each row in increasing order with respect
c    to the new ordering.  if  path.ne.1,  then nroc is assumed to have
c    been called already.
c
c nva   - r     - ordering of the rows of m.
c       -           size = n.
c nva   - c     - ordering of the columns of m.
c       -           size = n.
c nva   - ic    - inverse of the ordering of the columns of m.  i.e.,
c       -           ic(c(i)) = i  for i=1,...,n.
c       -           size = n.
c
c         the solution of the system of linear equations is divided into
c    three stages --
c      nsfc -- the matrix m is processed symbolically to determine where
c               fillin will occur during the numeric factorization.
c      nnfc -- the matrix m is factored numerically into the product ldu
c               of a unit lower triangular matrix l, a diagonal matrix
c               d, and a unit upper triangular matrix u, and the system
c               mx = b  is solved.
c      nnsc -- the linear system  mx = b  is solved using the ldu
c  or           factorization from nnfc.
c      nntc -- the transposed linear system  mt x = b  is solved using
c               the ldu factorization from nnf.
c    for several systems whose coefficient matrices have the same
c    nonzero structure, nsfc need be done only once (for the first
c    system).  then nnfc is done once for each additional system.  for
c    several systems with the same coefficient matrix, nsfc and nnfc
c    need be done only once (for the first system).  then nnsc or nntc
c    is done once for each additional right-hand side.
c
c nv    - path  - path specification.  values and their meanings are --
c       -           1  perform nroc, nsfc, and nnfc.
c       -           2  perform nnfc only  (nsfc is assumed to have been
c       -               done in a manner compatible with the storage
c       -               allocation used in the driver).
c       -           3  perform nnsc only  (nsfc and nnfc are assumed to
c       -               have been done in a manner compatible with the
c       -               storage allocation used in the driver).
c       -           4  perform nntc only  (nsfc and nnfc are assumed to
c       -               have been done in a manner compatible with the
c       -               storage allocation used in the driver).
c       -           5  perform nroc and nsfc.
c
c         various errors are detected by the driver and the individual
c    subroutines.
c
c nr    - flag  - error flag.  values and their meanings are --
c       -             0     no errors detected
c       -             n+k   null row in a  --  row = k
c       -            2n+k   duplicate entry in a  --  row = k
c       -            3n+k   insufficient storage in nsfc  --  row = k
c       -            4n+1   insufficient storage in nnfc
c       -            5n+k   null pivot  --  row = k
c       -            6n+k   insufficient storage in nsfc  --  row = k
c       -            7n+1   insufficient storage in nnfc
c       -            8n+k   zero pivot  --  row = k
c       -           10n+1   insufficient storage in cdrv
c       -           11n+1   illegal path specification
c
c         working storage is needed for the factored form of the matrix
c    m plus various temporary vectors.  the arrays isp and rsp should be
c    equivalenced.  integer storage is allocated from the beginning of
c    isp and real storage from the end of rsp.
c
c nv    - nsp   - declared dimension of rsp.  nsp generally must
c       -           be larger than  8n+2 + 2k  (where  k = (number of
c       -           nonzero entries in m)).
c nvira - isp   - integer working storage divided up into various arrays
c       -           needed by the subroutines.  isp and rsp should be
c       -           equivalenced.
c       -           size = lratio*nsp.
c fvira - rsp   - real working storage divided up into various arrays
c       -           needed by the subroutines.  isp and rsp should be
c       -           equivalenced.
c       -           size = nsp.
c nr    - esp   - if sufficient storage was available to perform the
c       -           symbolic factorization (nsfc), then esp is set to
c       -           the amount of excess storage provided (negative if
c       -           insufficient storage was available to perform the
c       -           numeric factorization (nnfc)).
c
c
c  conversion to double precision
c
c    to convert these routines for double precision arrays..
c    (1) use the double precision declarations in place of the real
c    declarations in each subprogram, as given in comment cards.
c    (2) change the data-loaded value of the integer  lratio
c    in subroutine cdrv, as indicated below.
c    (3) change e0 to d0 in the constants in statement number 10
c    in subroutine nnfc and the line following that.
c
      integer  r(*), c(*), ic(*),  ia(*), ja(*),  isp(*), esp,  path,
     *   flag,  d, u, q, row, tmp, ar,  umax
c     real  a(*), b(*), z(*), rsp(*)
      double precision  a(*), b(*), z(*), rsp(*)
c
c  set lratio equal to the ratio between the length of floating point
c  and integer array data.  e. g., lratio = 1 for (real, integer),
c  lratio = 2 for (double precision, integer)
c
      data lratio/2/
c
      if (path.lt.1 .or. 5.lt.path)  go to 111
c******initialize and divide up temporary storage  *******************
      il   = 1
      ijl  = il  + (n+1)
      iu   = ijl +   n
      iju  = iu  + (n+1)
      irl  = iju +   n
      jrl  = irl +   n
      jl   = jrl +   n
c
c  ******  reorder a if necessary, call nsfc if flag is set  ***********
      if ((path-1) * (path-5) .ne. 0)  go to 5
        max = (lratio*nsp + 1 - jl) - (n+1) - 5*n
        jlmax = max/2
        q     = jl   + jlmax
        ira   = q    + (n+1)
        jra   = ira  +   n
        irac  = jra  +   n
        iru   = irac +   n
        jru   = iru  +   n
        jutmp = jru  +   n
        jumax = lratio*nsp  + 1 - jutmp
        esp = max/lratio
        if (jlmax.le.0 .or. jumax.le.0)  go to 110
c
        do 1 i=1,n
          if (c(i).ne.i)  go to 2
   1      continue
        go to 3
   2    ar = nsp + 1 - n
        call  nroc
     *     (n, ic, ia,ja,a, isp(il), rsp(ar), isp(iu), flag)
        if (flag.ne.0)  go to 100
c
   3    call  nsfc
     *     (n, r, ic, ia,ja,
     *      jlmax, isp(il), isp(jl), isp(ijl),
     *      jumax, isp(iu), isp(jutmp), isp(iju),
     *      isp(q), isp(ira), isp(jra), isp(irac),
     *      isp(irl), isp(jrl), isp(iru), isp(jru),  flag)
        if(flag .ne. 0)  go to 100
c  ******  move ju next to jl  *****************************************
        jlmax = isp(ijl+n-1)
        ju    = jl + jlmax
        jumax = isp(iju+n-1)
        if (jumax.le.0)  go to 5
        do 4 j=1,jumax
   4      isp(ju+j-1) = isp(jutmp+j-1)
c
c  ******  call remaining subroutines  *********************************
   5  jlmax = isp(ijl+n-1)
      ju    = jl  + jlmax
      jumax = isp(iju+n-1)
      l     = (ju + jumax - 2 + lratio)  /  lratio    +    1
      lmax  = isp(il+n) - 1
      d     = l   + lmax
      u     = d   + n
      row   = nsp + 1 - n
      tmp   = row - n
      umax  = tmp - u
      esp   = umax - (isp(iu+n) - 1)
c
      if ((path-1) * (path-2) .ne. 0)  go to 6
        if (umax.lt.0)  go to 110
        call nnfc
     *     (n,  r, c, ic,  ia, ja, a, z, b,
     *      lmax, isp(il), isp(jl), isp(ijl), rsp(l),  rsp(d),
     *      umax, isp(iu), isp(ju), isp(iju), rsp(u),
     *      rsp(row), rsp(tmp),  isp(irl), isp(jrl),  flag)
        if(flag .ne. 0)  go to 100
c
   6  if ((path-3) .ne. 0)  go to 7
        call nnsc
     *     (n,  r, c,  isp(il), isp(jl), isp(ijl), rsp(l),
     *      rsp(d),    isp(iu), isp(ju), isp(iju), rsp(u),
     *      z, b,  rsp(tmp))
c
   7  if ((path-4) .ne. 0)  go to 8
        call nntc
     *     (n,  r, c,  isp(il), isp(jl), isp(ijl), rsp(l),
     *      rsp(d),    isp(iu), isp(ju), isp(iju), rsp(u),
     *      z, b,  rsp(tmp))
   8  return
c
c ** error.. error detected in nroc, nsfc, nnfc, or nnsc
 100  return
c ** error.. insufficient storage
 110  flag = 10*n + 1
      return
c ** error.. illegal path specification
 111  flag = 11*n + 1
      return
      end


PROGRAM main

  IMPLICIT NONE

  REAL :: v
  REAL, PARAMETER :: c = 299792458.0 ! m/s
  REAL :: beta, gamma

  PRINT*, "Enter velocity in m/s "

  READ(*, *) v

  ! I check if v > c. Later I check if it is so close to c that gamma overflows
  IF(v > c) THEN
    PRINT*, "Velocity exceeds speed of light! Try something slower"
    STOP
  END IF

  ! I don't bother to check if v << c, because gamma will be effectively
  ! 1 for all physics purposes in that case, so I don't really care about the accuracy

  ! I use the trick of keeping my calculation parts close to 1.
  beta = v/c

  ! Do the gamma calculation in 2 parts. First calculate 1/gamma. I use gamma
  ! as it's own temporary here. This is OK if you're careful
  gamma = sqrt(1.0 - beta*beta)

  ! Check if 1/gamma is too small to represent.
  ! I use "TINY" to get the smallest non-zero number

  IF(gamma < TINY(gamma)) THEN
    PRINT*, "Gamma has overflowed! Try something slower!"
  ELSE
    PRINT*, "Gamma is ", 1.0/gamma
  END IF

END PROGRAM


C+++++++++++++++++++++++++++++++++++++++++++++++++++++
C Extraction de la plus grande vp
C+++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C ierr=1 si pas de convergence apres itmax ités
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE PUISS(N,A,IA,JA,ALU,JLU,JU,Z,Y,xlmax,
     #                 itmax,xprec,ierr,iflag)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION A(*),IA(*),JA(*),Z(N),Y(N),
     #          ALU(*),JLU(*),JU(*)
C
      ERR  = 1.0D0
      ITE  = 0
      IERR = 0
      write(*,*)xprec,iflag
      read(*,*)
C
C     Vecteur initial
C     ---------------
      DO i=1,N
         z(i)=1.0D0
      ENDDO
C
C     Boucle principale
C     -----------------
 10   IF(ERR.LT.xprec) GOTO 99
C
         sum=0.0D0
         DO i=1,N
            sum=sum+z(i)*z(i)
         ENDDO
         sum=DSQRT(sum)
         DO i=1,N
            y(i)=z(i)/sum
         ENDDO
C
         SOLD=S
         CALL SMMV(N, A, IA, JA, Y, Z)
         if(iflag.ne.0)
     #      CALL LUSOL(N, z, z, ALU, JLU, JU)
         S = ProdScal(N, Y, Z)
         WRITE(*,*)'ite :',ITE,'lmax =',S,ERR
         ERR=DABS(S-SOLD)
         ITE=ITE+1
         IF(ITE.GT.ITMAX) THEN
            IERR=1
            GOTO 99
         ENDIF
      GOTO 10
C
 99   xlmax=S
C
      RETURN
      END


      subroutine setprob()
      implicit none

      double precision rho, bulk, cc, zz
      common /cparam/ rho,bulk,cc,zz

      double precision pi, pi2
      common /compi/ pi, pi2

      pi = 4.d0*atan(1.d0)
      pi2 = 2*pi

c     # These need to be assigned from user options
      open(10,file='setprob.data')
      read(10,*) rho
      read(10,*) bulk
      close(10)

      cc = sqrt(bulk/rho)
      zz = rho*cc

      return
      end


*DECK DPPDI
      SUBROUTINE DPPDI (AP, N, DET, JOB)
C***BEGIN PROLOGUE  DPPDI
C***PURPOSE  Compute the determinant and inverse of a real symmetric
C            positive definite matrix using factors from DPPCO or DPPFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B, D3B1B
C***TYPE      DOUBLE PRECISION (SPPDI-S, DPPDI-D, CPPDI-C)
C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX,
C             PACKED, POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPPDI computes the determinant and inverse
C     of a double precision symmetric positive definite matrix
C     using the factors computed by DPPCO or DPPFA .
C
C     On Entry
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                the output from DPPCO or DPPFA.
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        JOB     INTEGER
C                = 11   both determinant and inverse.
C                = 01   inverse only.
C                = 10   determinant only.
C
C     On Return
C
C        AP      the upper triangular half of the inverse .
C                The strict lower triangle is unaltered.
C
C        DET     DOUBLE PRECISION(2)
C                determinant of original matrix if requested.
C                Otherwise not referenced.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                with  1.0 .LE. DET(1) .LT. 10.0
C                or  DET(1) .EQ. 0.0 .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains
C        a zero on the diagonal and the inverse is requested.
C        It will not occur if the subroutines are called correctly
C        and if DPOCO or DPOFA has set INFO .EQ. 0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPPDI
      INTEGER N,JOB
      DOUBLE PRECISION AP(*)
      DOUBLE PRECISION DET(2)
C
      DOUBLE PRECISION T
      DOUBLE PRECISION S
      INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1
C***FIRST EXECUTABLE STATEMENT  DPPDI
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0D0
         DET(2) = 0.0D0
         S = 10.0D0
         II = 0
         DO 50 I = 1, N
            II = II + I
            DET(1) = AP(II)**2*DET(1)
            IF (DET(1) .EQ. 0.0D0) GO TO 60
   10       IF (DET(1) .GE. 1.0D0) GO TO 20
               DET(1) = S*DET(1)
               DET(2) = DET(2) - 1.0D0
            GO TO 10
   20       CONTINUE
   30       IF (DET(1) .LT. S) GO TO 40
               DET(1) = DET(1)/S
               DET(2) = DET(2) + 1.0D0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(R)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 140
         KK = 0
         DO 100 K = 1, N
            K1 = KK + 1
            KK = KK + K
            AP(KK) = 1.0D0/AP(KK)
            T = -AP(KK)
            CALL DSCAL(K-1,T,AP(K1),1)
            KP1 = K + 1
            J1 = KK + 1
            KJ = KK + K
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = AP(KJ)
               AP(KJ) = 0.0D0
               CALL DAXPY(K,T,AP(K1),1,AP(J1),1)
               J1 = J1 + J
               KJ = KJ + J
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM  INVERSE(R) * TRANS(INVERSE(R))
C
         JJ = 0
         DO 130 J = 1, N
            J1 = JJ + 1
            JJ = JJ + J
            JM1 = J - 1
            K1 = 1
            KJ = J1
            IF (JM1 .LT. 1) GO TO 120
            DO 110 K = 1, JM1
               T = AP(KJ)
               CALL DAXPY(K,T,AP(J1),1,AP(K1),1)
               K1 = K1 + K
               KJ = KJ + 1
  110       CONTINUE
  120       CONTINUE
            T = AP(JJ)
            CALL DSCAL(J,T,AP(J1),1)
  130    CONTINUE
  140 CONTINUE
      RETURN
      END


      PROGRAM LA_SSYEVR_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_SYEVR
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, M, N, IL, IU
!  .. "Local Arrays" ..
      INTEGER, ALLOCATABLE ::  ISUPPZ(:)
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), W(:), Z(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_SYEVR Example Program Results'
      N = 5
      ALLOCATE( A(N,N), AA(N,N), W(N), Z(N,N), ISUPPZ(2*N)  )

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

      AA=A

      WRITE(*,*)'Matrix A:'
      DO I=1,N;
         WRITE(*,"(5(F9.5))") A(I,:);
      ENDDO

      WRITE(*,*) 'CALL LA_SYEVR( A, W, Z=Z, ISUPPZ=ISUPPZ, IL=1, IU=2, M=M )'
      IL=1; IU=2

      CALL LA_SYEVR( A, W, IL=1, IU=2, M=M )

      WRITE(*,*)'Matrix A on exit :'
      DO I=1,N;
         WRITE(*,"(5(F9.5))") A(I,:);
      ENDDO

      WRITE(*,*)'M = ', M
      WRITE(*,*) 'W on exit :'
      DO I=1,M
         WRITE(*,"(5(F9.5))") W(I)
      ENDDO

      WRITE(*,*)'Z on exit :'
      DO I=1,N
         WRITE(*,"(5(E14.6))") Z(I,1:M)
      ENDDO
      WRITE(*,*)'ISUPPZ on exit:'
      WRITE(*,*) ISUPPZ(1:2*max(1,m))

      END PROGRAM LA_SSYEVR_EXAMPLE


C     LAST UPDATE 17/07/95
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE MNBRAK2(AX,BX,CX,FA,FB,FC,FUNC)
      IMPLICIT NONE
C
C Purpose: Given a function FUNC, and given distinct initial points AX
C          and BX, this routine searches in the downhill direction
C          (defined by the function as evaluated at the initial points)
C          and returns new points AX,BX,CX which bracket a minimum of
C          the function. Also returned are the function values at the
C          three points FA,FB,FC
C
C Calls   0:
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      REAL GOLD,GLIMIT,TINY
      PARAMETER(GOLD=1.618034, GLIMIT=100.0, TINY=1.0E-20)
C
C Arguments:
C
      REAL AX,BX,CX,FA,FB,FC
      REAL FUNC
      EXTERNAL FUNC
C
C External function:
C
      REAL F1DIM
      EXTERNAL F1DIM
C
C Local variables:
C
      REAL DUM,R,Q,U,ULIM,FU
C
C-----------------------------------------------------------------------
      FA = F1DIM(AX,FUNC)
      FB = F1DIM(BX,FUNC)
      IF(FB.GT.FA)THEN
         DUM = AX
         AX = BX
         BX = DUM
         DUM = FB
         FB = FA
         FA = DUM
      ENDIF
      CX = BX + GOLD*(BX-AX)
      FC = F1DIM(CX,FUNC)
 1    IF(FB.GE.FC)THEN
         R = (BX-AX)*(FB-FC)
         Q = (BX-CX)*(FB-FA)
         U = BX -((BX-CX)*Q-(BX-AX)*R)/
     &            2.0*SIGN(MAX(ABS(Q-R),TINY),Q-R)
         ULIM = BX + GLIMIT*(CX-BX)
         IF((BX-U)*(U-CX).GT.0.0)THEN
            FU = F1DIM(U,FUNC)
            IF(FU.LT.FC)THEN
               AX = BX
               FA = FB
               BX = U
               FB = FU
               RETURN
            ELSEIF(FU.GT.FB)THEN
               CX = U
               FC = FU
               RETURN
            ENDIF
            U = CX + GOLD*(CX-BX)
            FU = F1DIM(U,FUNC)
         ELSEIF((CX-U)*(U-ULIM).GT.0.0)THEN
            FU = F1DIM(U,FUNC)
            IF(FU.LT.FC)THEN
            BX = CX
            CX = U
            U = CX + GOLD*(CX-BX)
            FB = FC
            FC = FU
            FU = F1DIM(U,FUNC)
         ENDIF
         ELSEIF((U-ULIM)*(ULIM-CX).GE.0.0)THEN
            U = ULIM
            FU = F1DIM(U,FUNC)
         ELSE
            U = CX + GOLD*(CX-BX)
            FU = F1DIM(U,FUNC)
         ENDIF
         AX = BX
         BX = CX
         CX = U
         FA = FB
         FB = FC
         FC = FU
         GOTO 1
      ENDIF
      RETURN
C
      END


program test_blocking

    use linear_theory_winds
    use data_structures
    use icar_constants
    use mod_blocking,    only : compute_fft_topography, compute_blocked_flow_for_wind
    use io_routines,     only : io_write

    use iso_c_binding

    implicit none
    integer, parameter :: nx   = 200
    integer, parameter :: ny   = 200
    integer, parameter :: nz   = 15
    real    :: zmax = 1000
    real    :: dx   = 2000
    real    :: u    = 10
    real    :: v    = 0
    real, allocatable :: terrain(:,:)
    real :: z_layers(nz)
    type(linear_theory_type) :: lt_data
    integer :: i
    real, allocatable :: wfield(:,:,:)
    real, allocatable :: ufield(:,:,:)
    real, allocatable :: vfield(:,:,:)

    complex(C_DOUBLE_COMPLEX), allocatable  :: complex_terrain(:,:)
    complex(C_DOUBLE_COMPLEX), allocatable  :: fft_terrain(:,:)

    allocate(wfield(nx,nz,ny))
    wfield = 0
    allocate(ufield(nx,nz,ny))
    ufield = 0
    allocate(vfield(nx,nz,ny))
    vfield = 0
    allocate(complex_terrain(nx,ny))
    allocate(fft_terrain(nx,ny))

    call ideal_topography(nx,ny,zmax,terrain, 50)

    complex_terrain = terrain
    call compute_fft_topography(complex_terrain, fft_terrain)

    z_layers = [  50, 100, 300, 500, 500, 500, 500, 500, 500, 500, &
                 500, 500, 500, 500, 500]
    do i=2,nz
        z_layers(i) = z_layers(i-1) + z_layers(i)
    enddo

    call compute_blocked_flow_for_wind(u, v, z_layers, dx, fft_terrain, lt_data, ufield, vfield, debug=.False.)

    call io_write("ideal_terrain.nc","data",terrain)
    call io_write("ufield.nc", "data", ufield)
    call io_write("vfield.nc", "data", vfield)

    do i=1,nz
        wfield(2:nx-1, i, 2:ny-1) = ufield(3:nx,   i, 2:ny-1) - ufield(1:nx-2, i, 2:ny-1) &
                                  + vfield(2:nx-1, i, 3:ny  ) - vfield(2:nx-1, i, 1:ny-2)
    enddo
    call io_write("divergence.nc","data",wfield)

    wfield = wfield * (-1)

    do i=2,nz
        wfield(:,i,:) = wfield(:,i,:) + wfield(:,i-1,:)
    enddo
    call io_write("raww.nc","data",wfield)

    ! do i=1,nz
    !     wfield(2:nx-1, i, 2:ny-1) = wfield(2:nx-1, i, 2:ny-1)        &
    !                               + ufield(2:nx-1, i, 2:ny-1) * dzdx &
    !                               + vfield(2:nx-1, i, 2:ny-1) * dzdy
    ! enddo
    ! call io_write("w_full.nc","data",wfield)

contains

    subroutine ideal_topography(nx, ny, zmax, terrain, buffer_input)
        implicit none
        integer, intent(in) :: nx, ny
        real,    intent(in) :: zmax
        real,    intent(inout), allocatable :: terrain(:,:)
        integer, intent(in), optional :: buffer_input

        integer :: i,j
        integer :: buffer

        buffer = 0
        if (present(buffer_input)) buffer = buffer_input
        if (allocated(terrain)) deallocate(terrain)

        allocate(terrain(nx, ny))

        do i=buffer+1,nx-buffer
            do j=buffer+1,ny-buffer
                terrain(i,j) = (sin((i-buffer)/real(nx-(buffer*2)) * 2*pi - pi/2)/2+0.5) &
                                * (sin((j-buffer)/real(ny-(buffer*2)) * 2*pi - pi/2)/2+0.5) &
                                * zmax
            enddo
        enddo

    end subroutine ideal_topography

end program test_blocking


      PARAMETER (NHX=8, NRX=40)
      DIMENSION H(NHX), R(0:NRX)
      CHARACTER*5 HNAME(NHX)
      LOGICAL OK
C
      DATA H / 3.0, 3.5, 4.0, 5.0, 6.0, 8.0, 12.0, 20.0 /
      DATA HNAME / 'ai.03' ,
     &             'ai.35' ,
     &             'ai.04' ,
     &             'ai.05' ,
     &             'ai.06' ,
     &             'ai.08' ,
     &             'ai.12' ,
     &             'ai.20'   /
C
      FSP = 0.08
C
      DO IR=0, NRX
        R(IR) = 10.0 ** (FLOAT(IR)/10.0)
      ENDDO
C
      DO IH = 1, NHX
C
        OPEN(1,FILE=HNAME(IH),STATUS='unknown')
        WRITE(1,1000) '#', H(IH)
 1000   FORMAT(A, F10.5)
C
        DO IR=1, NRX
          CALL OSHAI(R(IR),FSP,H(IH), AI,
     &               AI_R, AI_F, AI_H,
     &               AIF_R,AIF_F,AIF_H , OK)
C
          WRITE(1,1200) LOG10(R(IR)), -AI
 1200     FORMAT(1X,F10.5, F12.6)
C
        ENDDO
        CLOSE(1)
      ENDDO
C
      STOP
      END


      SUBROUTINE CLAR2V( N, X, Y, Z, INCX, C, S, INCC )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INCC, INCX, N
*     ..
*     .. Array Arguments ..
      REAL               C( * )
      COMPLEX            S( * ), X( * ), Y( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*  CLAR2V applies a vector of complex plane rotations with real cosines
*  from both sides to a sequence of 2-by-2 complex Hermitian matrices,
*  defined by the elements of the vectors x, y and z. For i = 1,2,...,n
*
*     (       x(i)  z(i) ) :=
*     ( conjg(z(i)) y(i) )
*
*       (  c(i) conjg(s(i)) ) (       x(i)  z(i) ) ( c(i) -conjg(s(i)) )
*       ( -s(i)       c(i)  ) ( conjg(z(i)) y(i) ) ( s(i)        c(i)  )
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of plane rotations to be applied.
*
*  X       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)
*          The vector x; the elements of x are assumed to be real.
*
*  Y       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)
*          The vector y; the elements of y are assumed to be real.
*
*  Z       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)
*          The vector z.
*
*  INCX    (input) INTEGER
*          The increment between elements of X, Y and Z. INCX > 0.
*
*  C       (input) REAL array, dimension (1+(N-1)*INCC)
*          The cosines of the plane rotations.
*
*  S       (input) COMPLEX array, dimension (1+(N-1)*INCC)
*          The sines of the plane rotations.
*
*  INCC    (input) INTEGER
*          The increment between elements of C and S. INCC > 0.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IC, IX
      REAL               CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,
     $                   ZIR
      COMPLEX            SI, T2, T3, T4, ZI
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          AIMAG, CMPLX, CONJG, REAL
*     ..
*     .. Executable Statements ..
*
      IX = 1
      IC = 1
      DO 10 I = 1, N
         XI = REAL( X( IX ) )
         YI = REAL( Y( IX ) )
         ZI = Z( IX )
         ZIR = REAL( ZI )
         ZII = AIMAG( ZI )
         CI = C( IC )
         SI = S( IC )
         SIR = REAL( SI )
         SII = AIMAG( SI )
         T1R = SIR*ZIR - SII*ZII
         T1I = SIR*ZII + SII*ZIR
         T2 = CI*ZI
         T3 = T2 - CONJG( SI )*XI
         T4 = CONJG( T2 ) + SI*YI
         T5 = CI*XI + T1R
         T6 = CI*YI - T1R
         X( IX ) = CI*T5 + ( SIR*REAL( T4 )+SII*AIMAG( T4 ) )
         Y( IX ) = CI*T6 - ( SIR*REAL( T3 )-SII*AIMAG( T3 ) )
         Z( IX ) = CI*T3 + CONJG( SI )*CMPLX( T6, T1I )
         IX = IX + INCX
         IC = IC + INCC
   10 CONTINUE
      RETURN
*
*     End of CLAR2V
*
      END


C * * * * * * * * * * * * * * *
C --- DRIVER FOR RADAR5
C * * * * * * * * * * * * * * *
C       Use make command (relevant to Makefile)

        IMPLICIT REAL*8 (A-H,O-Z)

        INTEGER, PARAMETER :: DP=kind(1D0)
C --->  PARAMETERS FOR RADAR5 (FULL JACOBIAN) <---
        INTEGER, PARAMETER :: ND=1
        INTEGER, PARAMETER :: NRDENS=1
        INTEGER, PARAMETER :: NGRID=0
        INTEGER, PARAMETER :: NLAGS=1
        INTEGER, PARAMETER :: NJACL=1
        INTEGER, PARAMETER :: MXST=5000
        INTEGER, PARAMETER :: LWORK=30
        INTEGER, PARAMETER :: LIWORK=30
        REAL, dimension(2) :: TARRAY
        REAL(kind=DP), dimension(ND) :: Y
        REAL(kind=DP), dimension(NGRID+1) :: GRID
        REAL(kind=DP), dimension(LWORK) :: WORK
        REAL(kind=DP), dimension(1) :: RTOL
        REAL(kind=DP), dimension(1) :: ATOL
        INTEGER, dimension(LIWORK) :: IWORK
        INTEGER, dimension(NRDENS+1) :: IPAST
        INTEGER, dimension(22) :: ISTAT
        EXTERNAL  FCN,PHI,ARGLAG,JACLAG,QFUN,SOLOUT

C ------ FILE TO OPEN ----------
        OPEN(9,FILE='sol.out')
        OPEN(10,FILE='cont.out')
        REWIND 9
        REWIND 10

        WRITE(*,*) 'INSERT TOL '
        READ(*,*) TOL
C -----------------------------------------------------------------------
C
C --- DIMENSION OF THE SYSTEM
        N=ND
C --- COMPUTE THE STANDARD JACOBIAN ANALYTICALLY
        IJAC=0
C --- JACOBIAN IS A FULL MATRIX
        MLJAC=N
C --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
        IMAS=0
        MLMAS=N
C --- OUTPUT ROUTINE IS USED DURING INTEGRATION
        IOUT=1
C --- INITIAL VALUES
        X=2.0D0
        Y(1)=1.0D0
C       Consistent with initial function
C --- ENDPOINT OF INTEGRATION
        XEND=5.5D0
C       XEND=2.D0
C --- REQUIRED (RELATIVE AND ABSOLUTE) TOLERANCE
        ITOL=0
        RTOL=TOL
        ATOL=RTOL
C --- INITIAL STEP SIZE
        H=1.0D-2
C --- DEFAULT VALUES FOR PARAMETERS
        DO 10 I=1,20
        IWORK(I)=0
  10    WORK(I)=0.0D0
C --- ERROR CONTROL
        IWORK(11)=1
C --- STEPSIZE RATIOS
C       WORK(8)=0.5D0
C       WORK(9)=2.0D0
C --- WORKSPACE FOR PAST
        IWORK(12)=MXST
C --- BOTH COMPONENTS USE RETARDED ARGUMENT
        IWORK(15)=NRDENS
        IPAST(1)=1
C --- CONTROL OF NEWTON ITERATION
        IWORK(3)=10
        IWORK(14)=1
C --- GRID
        IWORK(13)=NGRID

C _____________________________________________________________________
C --- CALL OF THE SUBROUTINE RADAR5
        CALL DTIME(TARRAY)
        CALL RADAR5(N,FCN,PHI,ARGLAG,X,Y,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  JFCN,IJAC,MLJAC,MUJAC,
     &                  JACLAG,NLAGS,NJACL,
     &                  IMAS,SOLOUT,IOUT,
     &                  WORK,IWORK,RPAR,IPAR,IDID,
     &                  GRID,IPAST,QFUN,MLMAS,MUMAS)
        CALL DTIME(TARRAY)

C ---
        WRITE (6,*) 'Time = ',TARRAY(1)
        YT=-2.D0*LOG(EXP(-2.D0)*(1.D0-XEND+LOG(4.D0*EXP(4.D0))))
C --- PRINT FINAL SOLUTION SOLUTION
        WRITE (6,90) X,Y(1),ABS(Y(1)-YT)
C --- PRINT STATISTICS
         DO J=13,20
            ISTAT(J)=IWORK(J)
         END DO
        WRITE(6,*)' ***** TOL=',RTOL,' ****'
        WRITE (6,91) (ISTAT(J),J=14,20)
        WRITE (6,92) ISTAT(13)
 90     FORMAT(1X,'X =',F8.2,'    Y =',2E23.15)
 91     FORMAT(' fcn=',I7,' jac=',I6,' step=',I6,
     &        ' accpt=',I6,' rejct=',I6,' dec=',I6,
     &        ' sol=',I7)
 92     FORMAT(' full Newt. its =',I7)
        WRITE(6,*) 'SOLUTION IS TABULATED IN FILES: sol.out & cont.out'

        CLOSE(9)
        CLOSE(10)

        STOP
        END
C
C
        SUBROUTINE SOLOUT (NR,XOLD,X,HSOL,Y,CONT,LRC,N,
     &                     RPAR,IPAR,IRTRN)
C ----- PRINTS THE DISCRETE OUTPUT AND THE CONTINUOUS OUTPUT
C       AT EQUIDISTANT OUTPUT-POINTS
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), PARAMETER :: XSTEP=0.002D0
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(LRC) :: CONT
        REAL(kind=DP), dimension(1) :: RPAR
C       EXTERNAL PHI
C       XOUT IS USED FOR THE DENSE OUTPUT
        COMMON /INTERN/XOUT

        WRITE (9,99) X,Y(1)

        IF (NR.EQ.1) THEN
           WRITE (10,99) X,Y(1)
           XOUT=XSTEP
        ELSE
 10        CONTINUE
           IF (X.GE.XOUT) THEN
              WRITE (10,99) XOUT,CONTR5(1,N,XOUT,CONT,X,HSOL)
              XOUT=XOUT+XSTEP
              GOTO 10
           END IF
        END IF
 99     FORMAT(1X,'X =',F12.8,'    Y =',2E18.10)
        RETURN
        END
C
        DOUBLE PRECISION FUNCTION ARGLAG(IL,X,Y,RPAR,IPAR,
     &                                   PHI,PAST,IPAST,NRDS)
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: Y
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        INTEGER, dimension(1) :: IPAR
        REAL(kind=DP), dimension(1) :: RPAR

        ARGLAG=Y(1)

        RETURN
        END
C
        SUBROUTINE FCN(N,X,Y,F,ARGLAG,PHI,RPAR,IPAR,
     &                  PAST,IPAST,NRDS)
        IMPLICIT REAL*8 (A-H,K,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(N) :: F
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        REAL RN
        EXTERNAL PHI

        CALL LAGR5(1,X,Y,ARGLAG,PAST,THETA,IPOS,RPAR,IPAR,
     &                 PHI,IPAST,NRDS)
        Y1L1=YLAGR5(1,THETA,IPOS,PHI,RPAR,IPAR,
     &              PAST,IPAST,NRDS)

        F(1)= Y1L1
        RETURN
        END
C

        SUBROUTINE JACLAG(N,X,Y,DFYL,ARGLAG,PHI,IVE,IVC,IVL,
     &                    RPAR,IPAR,PAST,IPAST,NRDS)
C ----- JACOBIAN OF DELAY TERMS IN THE EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(1) :: DFYL
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        INTEGER, dimension(1) :: IVE,IVC,IVL
        EXTERNAL PHI

        IVL(1)=1
        IVE(1)=1
        IVC(1)=1
        DFYL(1)=1.D0

        RETURN
        END

C
CD      SUBROUTINE PHI(I,X,VAL,RPAR,IPAR)
        DOUBLE PRECISION FUNCTION PHI(I,X,RPAR,IPAR)
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: RPAR

        PHI=0.5D0

        RETURN
        END

        SUBROUTINE QFUN(N,Q,LQ,RPAR,IPAR)
C --- MATRIX "M" FOR THE TEST PROBLEM
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: RPAR
        REAL(kind=DP), dimension(LQ,N) :: Q

        Q(1,1)=1.D0
        RETURN
        END