      program grid_lonlat_2d
      use mod_za  ! HYCOM array I/O interface
      implicit none
c
      integer          i,ii,j,jj,mapflg
      logical          lperiod
      real*8           hmaxa,hmina,plonij,qlonij,ulonij,vlonij
      double precision pntlon,pntlat,oldlon,oldlat,deg2rad,rad2deg
      double precision x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4, tx,ty,tz,da

c
c --- create a specified longitude and latitude grid definition file.
c
c --- the 2-d fields plon and plat are input from fort.51A.
c --- plon and plat can be data-void for i=idm and j=jdm
c
c --- for compatibility:
c ---   idm,jdm are input from regional.grid.b,
c ---   and the output is to fort.61 and fort.61A
c ---   the latter should subsequently be renamed regional.grid.[ab].
c
      real*8 spherdist  ! fn for distance between geo. pos
c
      real*8,           parameter :: hspval = 0.5 * 2.0**100
      double precision, parameter :: half   = 0.5d0
      double precision, parameter :: halfpi = 1.5707963268d0
      double precision, parameter :: radian = 57.29578d0
c
      integer, allocatable :: ip(:,:)
      real*8,  allocatable :: pang(:,:),cori(:,:)
      real*8,  allocatable :: plon(:,:),qlon(:,:),ulon(:,:),vlon(:,:)
      real*8,  allocatable :: plat(:,:),qlat(:,:),ulat(:,:),vlat(:,:)
      real*8,  allocatable :: pscx(:,:),qscx(:,:),uscx(:,:),vscx(:,:)
      real*8,  allocatable :: pscy(:,:),qscy(:,:),uscy(:,:),vscy(:,:)
      real*8,  allocatable :: rlon(:,:),rlat(:,:)
c
      call xcspmd  !input idm,jdm
      allocate(   ip(idm,jdm) )
      allocate( pang(idm,jdm), cori(idm,jdm) )
      allocate( plat(idm,jdm), plon(idm,jdm) )
      allocate( qlat(idm,jdm), qlon(idm,jdm) )
      allocate( ulat(idm,jdm), ulon(idm,jdm) )
      allocate( vlat(idm,jdm), vlon(idm,jdm) )
      allocate( pscy(idm,jdm), pscx(idm,jdm) )
      allocate( qscy(idm,jdm), qscx(idm,jdm) )
      allocate( uscy(idm,jdm), uscx(idm,jdm) )
      allocate( vscy(idm,jdm), vscx(idm,jdm) )
      allocate( rlat(idm,jdm), rlon(idm,jdm) )
c
c --- read in the map projection.
c ---   'idm   ' = longitudinal array size
c ---   'jdm   ' = latitudinal  array size
c
      mapflg = -1
      call blkini(i,      'idm   ')
      call blkini(j,      'jdm   ')
c
      if     (i.ne.idm .or. j.ne.jdm) then
        write(lp,'(/a,a/)') 'stdin and regional.grid.b have',
     &                      ' different idm,jdm values'
        call flush(lp)
        stop
      endif
c
      call zaiost
      call zaiopn( 'old', 51)
      call zaiord8(plon,ip,.false., hmina,hmaxa, 51)
      call zaiord8(plat,ip,.false., hmina,hmaxa, 51)
      call zaiocl( 51)
c
c --- last row and column can contain data voids
c
      do j= 1,jdm-1
        if     (plon(idm,j).gt.hspval) then
          plon(idm,j) = 2.0 * plon(idm-1,j) - plon(idm-2,j)
          plat(idm,j) = 2.0 * plat(idm-1,j) - plat(idm-2,j)
        endif
      enddo
      do i= 1,idm
        if     (plon(i,jdm).gt.hspval) then
          plon(i,jdm) = 2.0 * plon(i,jdm-1) - plon(i,jdm-2)
          plat(i,jdm) = 2.0 * plat(i,jdm-1) - plat(i,jdm-2)
        endif
      enddo
c
c --- convert plon,plat to radians
c
      rad2deg = 180.d0/(4.d0*atan(1.d0))
      deg2rad = 1.d0/rad2deg
c
      do j= 1,jdm
        do i= 1,idm
          plon(i,j) = mod(plon(i,j),360.0) !-360 to +360
          if     (plon(i,j).gt. 180.0) then
            plon(i,j) = plon(i,j) - 360.0
          elseif (plon(i,j).lt.-180.0) then
            plon(i,j) = plon(i,j) + 360.0
          endif
          rlon(i,j) = plon(i,j)*deg2rad
          rlat(i,j) = plat(i,j)*deg2rad
        enddo !i
      enddo !j
c
c --- define the 4 staggered grids.
c
      do j= 2,jdm
        do i= 2,idm

            z1 = cos(rlat(i-1,j-1))
            x1 = cos(rlon(i-1,j-1))*z1
            y1 = sin(rlon(i-1,j-1))*z1
            z1 = sin(rlat(i-1,j-1))

            z2 = cos(rlat(i,j-1))
            x2 = cos(rlon(i,j-1))*z2
            y2 = sin(rlon(i,j-1))*z2
            z2 = sin(rlat(i,j-1))

            z3 = cos(rlat(i-1,j))
            x3 = cos(rlon(i-1,j))*z3
            y3 = sin(rlon(i-1,j))*z3
            z3 = sin(rlat(i-1,j))

            z4 = cos(rlat(i,j))
            x4 = cos(rlon(i,j))*z4
            y4 = sin(rlon(i,j))*z4
            z4 = sin(rlat(i,j))

          tx = (x1+x2+x3+x4)*0.25d0
          ty = (y1+y2+y3+y4)*0.25d0
          tz = (z1+z2+z3+z4)*0.25d0
          da = sqrt(tx**2+ty**2+tz**2)
          tz = tz/da
          if (tx /= 0.d0 .or. ty /= 0.d0) then
            qlon(i,j) = atan2(ty,tx)*rad2deg
          else
            qlon(i,j) = 0.d0
          endif
          qlat(i,j) = asin(tz)*rad2deg

          tx = (x3+x4)*0.5d0
          ty = (y3+y4)*0.5d0
          tz = (z3+z4)*0.5d0
          da = sqrt(tx**2+ty**2+tz**2)
          tz = tz/da
          if (tx /= 0.d0 .or. ty /= 0.d0) then
            ulon(i,j) = atan2(ty,tx)*rad2deg
          else
            ulon(i,j) = 0.d0
          endif
          ulat(i,j) = asin(tz)*rad2deg

          tx = (x2+x4)*0.5d0
          ty = (y2+y4)*0.5d0
          tz = (z2+z4)*0.5d0
          da = sqrt(tx**2+ty**2+tz**2)
          tz = tz/da
          if (tx /= 0.d0 .or. ty /= 0.d0) then
            vlon(i,j) = atan2(ty,tx)*rad2deg
          else
            vlon(i,j) = 0.d0
          endif
          vlat(i,j) = asin(tz)*rad2deg

        enddo !i
        qlat(1,j) = 2.0*qlat(2,j) - qlat(3,j)
        qlon(1,j) = 2.0*qlon(2,j) - qlon(3,j)
        ulat(1,j) = 2.0*ulat(2,j) - ulat(3,j)
        ulon(1,j) = 2.0*ulon(2,j) - ulon(3,j)
        vlat(1,j) = 2.0*vlat(2,j) - vlat(3,j)
        vlon(1,j) = 2.0*vlon(2,j) - vlon(3,j)
      enddo !j
      do i= 1,idm
        qlat(i,1) = 2.0*qlat(i,2) - qlat(i,3)
        qlon(i,1) = 2.0*qlon(i,2) - qlon(i,3)
        ulat(i,1) = 2.0*ulat(i,2) - ulat(i,3)
        ulon(i,1) = 2.0*ulon(i,2) - ulon(i,3)
        vlat(i,1) = 2.0*vlat(i,2) - vlat(i,3)
        vlon(i,1) = 2.0*vlon(i,2) - vlon(i,3)
      enddo
c
c --- modify ?lon to reduce jumps on longitude.
c
      do j= 1,jdm
        do i= 1,idm
          qlonij = qlon(i,j)
          if     (i.eq.1) then
c ---       close to previous row
            if     (j.ne.1) then
            if     (qlonij-qlon(i,j-1).gt. 180.0) then
              qlonij = qlonij-360.0
            elseif (qlonij-qlon(i,j-1).lt.-180.0) then
              qlonij = qlonij+360.0
            endif
            endif
          else
c ---       close to previous column
            if     (qlonij-qlon(i-1,j).gt. 180.0) then
              qlonij = qlonij-360.0
            elseif (qlonij-qlon(i-1,j).lt.-180.0) then
              qlonij = qlonij+360.0
            endif
            if     (qlonij-qlon(i-1,j).gt. 180.0) then
              qlonij = qlonij-360.0
            elseif (qlonij-qlon(i-1,j).lt.-180.0) then
              qlonij = qlonij+360.0
            endif
          endif
          qlon(i,j) = qlonij
c
          plonij = plon(i,j)
          if     (i.eq.1) then
c ---       close to previous row
            if     (j.ne.1) then
            if     (plonij-plon(i,j-1).gt. 180.0) then
              plonij = plonij-360.0
            elseif (plonij-plon(i,j-1).lt.-180.0) then
              plonij = plonij+360.0
            endif
            endif
          else
c ---       close to previous column
            if     (plonij-plon(i-1,j).gt. 180.0) then
              plonij = plonij-360.0
            elseif (plonij-plon(i-1,j).lt.-180.0) then
              plonij = plonij+360.0
            endif
            if     (plonij-plon(i-1,j).gt. 180.0) then
              plonij = plonij-360.0
            elseif (plonij-plon(i-1,j).lt.-180.0) then
              plonij = plonij+360.0
            endif
          endif
          plon(i,j) = plonij
c
          ulonij = ulon(i,j)
          if     (i.eq.1) then
c ---       close to previous row
            if     (j.ne.1) then
            if     (ulonij-ulon(i,j-1).gt. 180.0) then
              ulonij = ulonij-360.0
            elseif (ulonij-ulon(i,j-1).lt.-180.0) then
              ulonij = ulonij+360.0
            endif
            endif
          else
c ---       close to previous column
            if     (ulonij-ulon(i-1,j).gt. 180.0) then
              ulonij = ulonij-360.0
            elseif (ulonij-ulon(i-1,j).lt.-180.0) then
              ulonij = ulonij+360.0
            endif
            if     (ulonij-ulon(i-1,j).gt. 180.0) then
              ulonij = ulonij-360.0
            elseif (ulonij-ulon(i-1,j).lt.-180.0) then
              ulonij = ulonij+360.0
            endif
          endif
          ulon(i,j) = ulonij
c
          vlonij = vlon(i,j)
          if     (i.eq.1) then
c ---       close to previous row
            if     (j.ne.1) then
            if     (vlonij-vlon(i,j-1).gt. 180.0) then
              vlonij = vlonij-360.0
            elseif (vlonij-vlon(i,j-1).lt.-180.0) then
              vlonij = vlonij+360.0
            endif
            endif
          else
c ---       close to previous column
            if     (vlonij-vlon(i-1,j).gt. 180.0) then
              vlonij = vlonij-360.0
            elseif (vlonij-vlon(i-1,j).lt.-180.0) then
              vlonij = vlonij+360.0
            endif
            if     (vlonij-vlon(i-1,j).gt. 180.0) then
              vlonij = vlonij-360.0
            elseif (vlonij-vlon(i-1,j).lt.-180.0) then
              vlonij = vlonij+360.0
            endif
          endif
          vlon(i,j) = vlonij
c
        enddo !i
      enddo !j
c
      write(6, *)
      do j= 1,jdm
        write(6,'(a,i5,2f10.3)')
     &    'j,qlat =',j,minval(qlat(:,j)),maxval(qlat(:,j))
        write(6,'(a,i5,2f10.3)')
     &    'j,plat =',j,minval(plat(:,j)),maxval(plat(:,j))
      enddo
      write(6, *)
      do i= 1,idm
        write(6,'(a,i5,2f10.3)')
     &    'i,qlon =',i,minval(qlon(i,:)),maxval(qlon(i,:))
        write(6,'(a,i5,2f10.3)')
     &    'i,plon =',i,minval(plon(i,:)),maxval(plon(i,:))
      enddo
c
c --- finite difference approximation for pang.
c
      call rotang(plat,plon,idm,jdm,pang)
c
c --- write header.
c
      call zhopen(61, 'formatted', 'new', 0)
      write(61,'(i5,a)')
     &  idm,   "    'idm   ' = longitudinal array size"
      write(61,'(i5,a)')
     &  jdm,   "    'jdm   ' = latitudinal  array size"
      write(61,'(i5,a,a)')
     &  mapflg,"    'mapflg' = map flag",
     &         " (-1=unknown,0=mercator,2=uniform,4=f-plane)"
c
      write(6, *)
      write(6,'(i5,a)')
     &  idm,   "    'idm   ' = longitudinal array size"
      write(6,'(i5,a)')
     &  jdm,   "    'jdm   ' = latitudinal  array size"
      write(6,'(i5,a)')
     &  mapflg,"    'mapflg' = map flag (-1=unknown,0=mercator,...)"
c
c --- write grid arrays.
c
      call zaiopn('new', 61)
      call zaiowr8(plon, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'plon',hmina,hmaxa
      write(6, 6100) 'plon',hmina,hmaxa
      call zaiowr8(plat, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'plat',hmina,hmaxa
      write(6, 6100) 'plat',hmina,hmaxa
      call zaiowr8(qlon, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'qlon',hmina,hmaxa
      write(6, 6100) 'qlon',hmina,hmaxa
      call zaiowr8(qlat, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'qlat',hmina,hmaxa
      write(6, 6100) 'qlat',hmina,hmaxa
      call zaiowr8(ulon, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'ulon',hmina,hmaxa
      write(6, 6100) 'ulon',hmina,hmaxa
      call zaiowr8(ulat, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'ulat',hmina,hmaxa
      write(6, 6100) 'ulat',hmina,hmaxa
      call zaiowr8(vlon, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'vlon',hmina,hmaxa
      write(6, 6100) 'vlon',hmina,hmaxa
      call zaiowr8(vlat, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'vlat',hmina,hmaxa
      write(6, 6100) 'vlat',hmina,hmaxa
      call zaiowr8(pang, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'pang',hmina,hmaxa
      write(6, 6100) 'pang',hmina,hmaxa
      write(6, *)
 6100 format(a,':  min,max = ',2f15.5)
c
c --- grid spacing in meters.
c
      lperiod = maxval(plon(:,:))-minval(plon(:,:)) .gt. 350.0
      if     (lperiod) then
        lperiod = spherdist(plon(1,  2),plat(1,  2),
     &                      plon(idm,2),plat(idm,2) ) .lt.
     &            spherdist(plon(1,  2),plat(1,  2),
     &                      plon(2,  2),plat(2,  2) )*3.0
      endif
      if     (lperiod) then
        write(6,'(a)') 'domain assumed to be periodic'
      else
        write(6,'(a)') 'domain assumed to be non-periodic'
      endif
c
      hmina = 100.0 !100m minimum grid spacing
      do j= 1,jdm
        do i= 2,idm
          uscx(i,j) = spherdist(plon(i,  j),plat(i,  j),
     &                          plon(i-1,j),plat(i-1,j) )
          qscx(i,j) = spherdist(vlon(i,  j),vlat(i,  j),
     &                          vlon(i-1,j),vlat(i-1,j) )
          uscx(i,j) = max(uscx(i,j),hmina)
          qscx(i,j) = max(qscx(i,j),hmina)
        enddo
        i=1
        if     (lperiod) then
          uscx(i,j) = spherdist(plon(i,  j),plat(i,  j),
     &                          plon(idm,j),plat(idm,j) )
          qscx(i,j) = spherdist(vlon(i,  j),vlat(i,  j),
     &                          vlon(idm,j),vlat(idm,j) )
          uscx(i,j) = max(uscx(i,j),hmina)
          qscx(i,j) = max(qscx(i,j),hmina)
        else
          uscx(i,j) = uscx(i+1,j)  ! updated below except in corner
          qscx(i,j) = qscx(i+1,j)  ! updated below except in corner
        endif
        do i= 1,idm-1
          vscx(i,j) = spherdist(qlon(i,  j),qlat(i,  j),
     &                          qlon(i+1,j),qlat(i+1,j) )
          pscx(i,j) = spherdist(ulon(i,  j),ulat(i,  j),
     &                          ulon(i+1,j),ulat(i+1,j) )
          vscx(i,j) = max(vscx(i,j),hmina)
          pscx(i,j) = max(pscx(i,j),hmina)
        enddo
        i=idm
        if     (lperiod) then
          vscx(i,j) = spherdist(qlon(i,  j),qlat(i,  j),
     &                          qlon(1,  j),qlat(1,  j) )
          pscx(i,j) = spherdist(ulon(i,  j),ulat(i,  j),
     &                          ulon(1,  j),ulat(1,  j) )
          vscx(i,j) = max(vscx(i,j),hmina)
          pscx(i,j) = max(pscx(i,j),hmina)
        else
          vscx(i,j) = vscx(i-1,j)  ! updated below except in corner
          pscx(i,j) = pscx(i-1,j)  ! updated below except in corner
        endif
      enddo
c
      do j= 1,jdm
        if     (j.ne.1) then
          do i= 1,idm
            vscy(i,j) = spherdist(plon(i,  j),plat(i,  j),
     &                            plon(i,j-1),plat(i,j-1) )
            qscy(i,j) = spherdist(ulon(i,  j),ulat(i,  j),
     &                            ulon(i,j-1),ulat(i,j-1) )
            vscy(i,j) = max(vscy(i,j),hmina)
            qscy(i,j) = max(qscy(i,j),hmina)
          enddo
        endif
        if     (j.ne.jdm) then
          do i= 1,idm
            uscy(i,j) = spherdist(qlon(i,  j),qlat(i,  j),
     &                            qlon(i,j+1),qlat(i,j+1) )
            pscy(i,j) = spherdist(vlon(i,  j),vlat(i,  j),
     &                            vlon(i,j+1),vlat(i,j+1) )
            uscy(i,j) = max(uscy(i,j),hmina)
            pscy(i,j) = max(pscy(i,j),hmina)
          enddo
        endif
      enddo
c
c     fill in the edges, assuming constant grid aspect ratio
c
      j=1
      do i= 1,idm
        vscy(i,j) = vscx(i,j)*vscy(i,j+1)/vscx(i,j+1)
        qscy(i,j) = qscx(i,j)*qscy(i,j+1)/qscx(i,j+1)
        vscy(i,j) = max(vscy(i,j),hmina)
        qscy(i,j) = max(qscy(i,j),hmina)
      enddo
      j=jdm
      do i= 1,idm
        uscy(i,j) = uscx(i,j)*uscy(i,j-1)/uscx(i,j-1)
        pscy(i,j) = pscx(i,j)*pscy(i,j-1)/pscx(i,j-1)
        uscy(i,j) = max(uscy(i,j),hmina)
        pscy(i,j) = max(pscy(i,j),hmina)
      enddo
c
      if     (.not.lperiod) then
        i=1
        do j= 1,jdm
          uscx(i,j) = uscy(i,j)*uscx(i+1,j)/uscy(i+1,j)
          qscx(i,j) = qscy(i,j)*qscx(i+1,j)/qscy(i+1,j)
          uscx(i,j) = max(uscx(i,j),hmina)
          qscx(i,j) = max(qscx(i,j),hmina)
        enddo
        i=idm
        do j= 1,jdm
          vscx(i,j) = vscy(i,j)*vscx(i-1,j)/vscy(i-1,j)
          pscx(i,j) = pscy(i,j)*pscx(i-1,j)/pscy(i-1,j)
          vscx(i,j) = max(vscx(i,j),hmina)
          pscx(i,j) = max(pscx(i,j),hmina)
        enddo
      endif
c
      write(6, *)
      do j= 1,jdm
        write(6,'(a,i5,3f10.2)')
     &    'j,vy =',j,minval(vscy(:,j)),maxval(vscy(:,j)),
     &               maxval(vscy(:,j))-minval(vscy(:,j))
        write(6,'(a,i5,3f10.2)')
     &    'j,vx =',j,minval(vscx(:,j)),maxval(vscx(:,j)),
     &               maxval(vscx(:,j))-minval(vscx(:,j))
        write(6,'(a,i5,3f10.2)')
     &    'j,uy =',j,minval(uscy(:,j)),maxval(uscy(:,j)),
     &               maxval(uscy(:,j))-minval(uscy(:,j))
        write(6,'(a,i5,3f10.2)')
     &    'j,ux =',j,minval(uscx(:,j)),maxval(uscx(:,j)),
     &               maxval(uscx(:,j))-minval(uscx(:,j))
      enddo
      write(6, *)
c
c --- write grid arrays.
c
      call zaiowr8(pscx, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'pscx',hmina,hmaxa
      write(6, 6110) 'pscx',hmina,hmaxa
      call zaiowr8(pscy, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'pscy',hmina,hmaxa
      write(6, 6110) 'pscy',hmina,hmaxa
      call zaiowr8(qscx, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'qscx',hmina,hmaxa
      write(6, 6110) 'qscx',hmina,hmaxa
      call zaiowr8(qscy, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'qscy',hmina,hmaxa
      write(6, 6110) 'qscy',hmina,hmaxa
      call zaiowr8(uscx, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'uscx',hmina,hmaxa
      write(6, 6110) 'uscx',hmina,hmaxa
      call zaiowr8(uscy, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'uscy',hmina,hmaxa
      write(6, 6110) 'uscy',hmina,hmaxa
      call zaiowr8(vscx, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'vscx',hmina,hmaxa
      write(6, 6110) 'vscx',hmina,hmaxa
      call zaiowr8(vscy, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'vscy',hmina,hmaxa
      write(6, 6110) 'vscy',hmina,hmaxa
      write(6, *)
 6110 format(a,':  min,max = ',2f15.5)
c
c --- coriolis
c
      do j= 1,jdm
        do i= 1,idm
          cori(i,j)=sin(qlat(i,j)/radian)*
     &              8.d0*halfpi/86164.0d0  ! sidereal day
        enddo
      enddo
c
      call zaiowr8(cori, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6120) 'cori',hmina,hmaxa
      write(6, 6120) 'cori',hmina,hmaxa
      write(6, *)
 6120 format(a,':  min,max = ',2f15.10)
c
c --- grid aspect ratio.
c
      do j= 1,jdm
        do i= 1,idm
          if     (pscy(i,j).eq.0.0) then
            pscx(i,j) = 99.0
          elseif (pscx(i,j).ge.99.0*pscy(i,j)) then
            pscx(i,j) = 99.0
          else
            pscx(i,j) = pscx(i,j)/pscy(i,j)
          endif
        enddo
      enddo
c
      call zaiowr8(pscx, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6130) 'pasp',hmina,hmaxa
      write(6, 6130) 'pasp',hmina,hmaxa
      write(6, *)
 6130 format(a,':  min,max = ',2f15.5)
c
      close(unit=61)
      call zaiocl(61)
c
      end
      subroutine blkinr(rvar,cvar,cfmt)
      implicit none
c
      double precision rvar
      character        cvar*6,cfmt*(*)
c
      integer       lp
      common/linepr/lp
c
c     read in one real value from stdin
c
      character*6 cvarin
c
      read(*,*) rvar,cvarin
      write(lp,cfmt) cvarin,rvar
      call flush(lp)
c
      if     (cvar.ne.cvarin) then
        write(lp,*)
        write(lp,*) 'error in blkinr - input ',cvarin,
     +                      ' but should be ',cvar
        write(lp,*)
        call flush(lp)
        stop
      endif
      return
      end
      subroutine blkini(ivar,cvar)
      implicit none
c
      integer     ivar
      character*6 cvar
c
      integer       lp
      common/linepr/lp
c
c     read in one integer value from stdin
c
      character*6 cvarin
c
      read(*,*) ivar,cvarin
      write(lp,6000) cvarin,ivar
      call flush(lp)
c
      if     (cvar.ne.cvarin) then
        write(lp,*)
        write(lp,*) 'error in blkini - input ',cvarin,
     +                      ' but should be ',cvar
        write(lp,*)
        call flush(lp)
        stop
      endif
      return
 6000 format('blkini: ',a6,' =',i6)
      end


c
c
c =========================================================
      subroutine src2(maxmx,maxmy,meqn,mbc,mx,my,xlower,ylower,dx,dy,
     &             q,maux,aux,t,dt)
c =========================================================
      use geoclaw_module

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

      dimension   q(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc, meqn)
      dimension aux(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc, maux)
c

c     # incorporates friction using Manning coefficient

      if (coeffmanning.eq.0.d0 .or. frictiondepth.eq.0) return

c     # check for NANs in solution:
c     call check4nans(maxmx,maxmy,meqn,mbc,mx,my,q,t,2)

      g=grav
      coeff = coeffmanning
      tol = 1.d-30  !# to prevent divide by zero in gamma

*     ! friction--------------------------------------------------------
      if (coeffmanning.gt.0.d0.and.frictiondepth.gt.0.d0) then
         do i=1,mx
            do j=1,my

               h=q(i,j,1)
               if (h.le.frictiondepth) then
c                 # apply friction source term only in shallower water
                  hu=q(i,j,2)
                  hv=q(i,j,3)

                  if (h.lt.tol) then
                     q(i,j,2)=0.d0
                     q(i,j,3)=0.d0
                  else
                     gamma= dsqrt(hu**2 + hv**2)*(g*coeff**2)/(h**(7/3))
                     dgamma=1.d0 + dt*gamma
                     q(i,j,2)= q(i,j,2)/dgamma
                     q(i,j,3)= q(i,j,3)/dgamma
                  endif
               endif
            enddo
         enddo
      endif
*     ! ----------------------------------------------------------------

*     ! coriolis--------------------------------------------------------
      if (icoordsys.eq.2.and.icoriolis.eq.1) then
         w = 2.d0*pi/(86400.d0) !angular velocity of earth
         do i=1,mx
            do j=1,my
               ycell = ylower + (j-.5d0)*dy
               cor = 2.d0*w*sin(pi*ycell/180.d0)
               ct = cor*dt
*              !integrate momentum exactly using matrix exponential
*              !forth order term should be sufficient since cor^3 ~= eps
               hu0 = q(i,j,2)
               hv0 = q(i,j,3)
*              !dq/dt = 2w*sin(latitude)*[0 1 ; -1 0] q = Aq
*              !e^Adt = [a11 a12; a21 a22] + I
               a11 = -0.5d0*ct**2 + ct**4/24.d0
               a12 = ct - ct**3/6.0d0
               a21 = -ct + ct**3/6.0d0
               a22 = a11
*              !q = e^Adt * q0
               q(i,j,2) = q(i,j,2) + hu0*a11 + hv0*a12
               q(i,j,3) = q(i,j,3) + hu0*a21 + hv0*a22
            enddo
         enddo
      endif
*     ! ----------------------------------------------------------------
c
      return
      end


!----------------------------------------------------------------------------
! This file is part of UCLALES.
!
! UCLALES is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! UCLALES is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! Copyright 1999-2008, Bjorn B. Stevens, Dep't Atmos and Ocean Sci, UCLA
!----------------------------------------------------------------------------
!
module solver

  use defs, only : nv, nv1, pi
  implicit none
 !
  ! u denotes the Double-Gauss quadratures and weights (Sykes, 1951).
  ! the p0-p3 denote the legendre polynomials for x=u(1) to u(4)
  ! respectively.  p11d(4,4), p22d(4,4), and p33d(4,4) are defined as
  ! 0.5*p1d(i)*p1d(j), 0.5*p2d(i)*p2d(j), and 0.5*p3d(i)*p3d(j) resp.
  !
  real, parameter :: u(4) = (/-0.7886752,-0.2113247,0.2113247,0.7886752/)
  real, parameter :: p0d(4)= (/ 1., 1., 1., 1./)
  real, parameter :: p1d(4)= (/-0.788675, -.211325,  .211325, .788675/)
  real, parameter :: p2d(4)= (/ 0.433013, -.433013, -.433013, .433013/)
  real, parameter :: p3d(4)= (/-.0433940,  .293394, -.293394, .043394/)
  real, parameter, dimension(4, 4) ::                       &
    p11d = reshape(                                         &
    (/ .311004E+00, .833334E-01,-.833334E-01,-.311004E+00,  &
       0.833334E-01, .223291E-01,-.223291E-01,-.833334E-01, &
       -.833334E-01,-.223291E-01, .223291E-01, .833334E-01, &
       -.311004E+00,-.833334E-01, .833334E-01, .311004E+00  /), (/ 4, 4 /))
  real, parameter, dimension(4, 4) ::                       &
   p22d = reshape(                                          &
    (/ .937501E-01,-.937501E-01,-.937501E-01, .937501E-01,  &
       -.937501E-01, .937501E-01, .937501E-01,-.937501E-01, &
       -.937501E-01, .937501E-01, .937501E-01,-.937501E-01, &
       0.937501E-01,-.937501E-01,-.937501E-01, .937501E-01  /), (/ 4, 4 /))
  real, parameter, dimension(4, 4) ::                       &
    p33d = reshape(                                         &
    (/ .941520E-03,-.636577E-02, .636577E-02,-.941520E-03,  &
       -.636577E-02, .430400E-01,-.430400E-01, .636577E-02, &
       0.636577E-02,-.430400E-01, .430400E-01,-.636577E-02, &
       -.941520E-03, .636577E-02,-.636577E-02, .941520E-03  /), (/ 4, 4 /))

contains

  ! **********************************************************************
  ! coefficient calculations for four first-order differential equations.
  !
  ! See the paper by Liou, Fu and Ackerman (1988) for the formulation of
  ! the delta-four-stream approximation in a homogeneous layer.
  ! **********************************************************************
  subroutine coefft(solar,w,w1,w2,w3,t0,t1,u0,f0,aa,zz,a1,z1,fk1,fk2)

    logical, intent (in) :: solar
    real, intent(in)     :: w, w1, w2, w3, t0, t1, u0, f0
    real, intent (out)   :: aa(4,4,2), zz(4,2), a1(4,4), z1(4), fk1, fk2

    integer :: i, j
    real :: a(2,2,2), b(4,3), c(4,5), d(4), z(4), b1, c1, fw, fw1, fw2 &
         ,fw3, fw4, w0w, w1w, w2w, w3w, q1, q2, q3, zx, x, y, a2, b2   &
         ,fq0, fq1, fq, dt

    x = 0.5 * w
    w0w = x
    w1w = x * w1
    w2w = x * w2
    w3w = x * w3
    if ( solar ) then
       fw = u0 * u0
       q1 = - w1w * u0
       q2 =   w2w * ( 1.5 * fw - 0.5 )
       q3 = - w3w * ( 2.5 * fw - 1.5 ) * u0
       do i = 1, 4
          c(i,5) = (w0w + q1*p1d(i) + q2*p2d(i) + q3*p3d(i))/u(i)
       end do
    else
       do i = 1, 4
          c(i,5) = 1.0/ u(i)
       end do
    endif

    fq = 0.5 * w0w
    do i = 3, 4
       do j = 1, 4
          c(i,j) = fq + w1w*p11d(i,j) + w2w*p22d(i,j) + w3w*p33d(i,j)
          if ( i .eq. j ) then
             c(i,j) = ( c(i,j) - 1.0 ) / u(i)
          else
             c(i,j) = c(i,j) / u(i)
          endif
       end do
    end do

    b(1,1) = c(4,4) - c(4,1)
    b(1,2) = c(4,4) + c(4,1)
    b(2,1) = c(4,3) - c(4,2)
    b(2,2) = c(4,3) + c(4,2)
    b(3,1) = c(3,4) - c(3,1)
    b(3,2) = c(3,4) + c(3,1)
    b(4,1) = c(3,3) - c(3,2)
    b(4,2) = c(3,3) + c(3,2)
    b(1,3) = c(4,5) - c(1,5)
    b(2,3) = c(3,5) - c(2,5)
    b(3,3) = c(3,5) + c(2,5)
    b(4,3) = c(4,5) + c(1,5)
    ! **********************************************************************
    ! coefficient calculations for second order differential equations.
    ! **********************************************************************
    fw1 = b(1,1) * b(1,2)
    fw2 = b(2,1) * b(3,2)
    fw3 = b(3,1) * b(2,2)
    fw4 = b(4,1) * b(4,2)
    a(2,2,1) = fw1 + fw2
    a(2,1,1) = b(1,1) * b(2,2) + b(2,1) * b(4,2)
    a(1,2,1) = b(3,1) * b(1,2) + b(4,1) * b(3,2)
    a(1,1,1) = fw3 + fw4
    a(2,2,2) = fw1 + fw3
    a(2,1,2) = b(1,2) * b(2,1) + b(2,2) * b(4,1)
    a(1,2,2) = b(3,2) * b(1,1) + b(4,2) * b(3,1)
    a(1,1,2) = fw2 + fw4
    d(1) = b(3,2) * b(4,3) + b(4,2) * b(3,3) + b(2,3) / u0
    d(2) = b(1,2) * b(4,3) + b(2,2) * b(3,3) + b(1,3) / u0
    d(3) = b(3,1) * b(1,3) + b(4,1) * b(2,3) + b(3,3) / u0
    d(4) = b(1,1) * b(1,3) + b(2,1) * b(2,3) + b(4,3) / u0

    ! **********************************************************************
    ! coefficient calculations for fourth-order differential equations.
    ! **********************************************************************
    x = u0 * u0
    b1 = a(2,2,1) + a(1,1,1)
    c1 = a(2,1,1) * a(1,2,1) - a(1,1,1) * a(2,2,1)
    z(1) = a(2,1,1) * d(3) + d(4) / x - a(1,1,1) * d(4)
    z(2) = a(1,2,1) * d(4) - a(2,2,1) *d(3) + d(3) / x
    z(3) = a(2,1,2) * d(1) + d(2) / x - a(1,1,2) * d(2)
    z(4) = a(1,2,2) * d(2) - a(2,2,2) * d(1) + d(1) / x

    ! **********************************************************************
    ! fk1 and fk2 are the eigenvalues.
    ! **********************************************************************
    dt = t1 - t0
    x = sqrt ( b1 * b1 + 4.0 * c1 )
    fk1 = sqrt ( ( b1 + x ) * 0.5 )
    fk2 = sqrt ( ( b1 - x ) * 0.5 )
    fw = u0 * u0
    x = 1.0 / ( fw * fw ) - b1 / fw - c1
    fw = 0.5 * f0 / x
    z(1) = fw * z(1)
    z(2) = fw * z(2)
    z(3) = fw * z(3)
    z(4) = fw * z(4)
    z1(1) = 0.5 * ( z(1) + z(3) )
    z1(2) = 0.5 * ( z(2) + z(4) )
    z1(3) = 0.5 * ( z(2) - z(4) )
    z1(4) = 0.5 * ( z(1) - z(3) )
    a2 = ( fk1 * fk1 - a(2,2,1) ) / a(2,1,1)
    b2 = ( fk2 * fk2 - a(2,2,1) ) / a(2,1,1)
    x = b(1,1) * b(4,1) - b(3,1) * b(2,1)
    fw1 = fk1 / x
    fw2 = fk2 / x
    y = fw2 * ( b2 * b(2,1) - b(4,1) )
    zx = fw1 * ( a2 * b(2,1) - b(4,1) )
    a1(1,1) = 0.5 * ( 1 - y )
    a1(1,2) = 0.5 * ( 1 - zx )
    a1(1,3) = 0.5 * ( 1 + zx )
    a1(1,4) = 0.5 * ( 1 + y )
    y = fw2 * ( b(3,1) - b2 * b(1,1) )
    zx = fw1 * ( b(3,1) - a2 * b(1,1) )
    a1(2,1) = 0.5 * ( b2 - y )
    a1(2,2) = 0.5 * ( a2 - zx )
    a1(2,3) = 0.5 * ( a2 + zx )
    a1(2,4) = 0.5 * ( b2 + y )
    a1(3,1) = a1(2,4)
    a1(3,2) = a1(2,3)
    a1(3,3) = a1(2,2)
    a1(3,4) = a1(2,1)
    a1(4,1) = a1(1,4)
    a1(4,2) = a1(1,3)
    a1(4,3) = a1(1,2)
    a1(4,4) = a1(1,1)
    if ( solar ) then
       fq0 = exp ( - t0 / u0 )
       fq1 = exp ( - t1 / u0 )
    else
       fq0 = 1.0
       fq1 = exp ( - dt / u0 )
    endif
    x = exp ( - fk1 * dt )
    y = exp ( - fk2 * dt )
    do i = 1, 4
       zz(i,1) = z1(i) * fq0
       zz(i,2) = z1(i) * fq1
       aa(i,1,1) = a1(i,1)
       aa(i,2,1) = a1(i,2)
       aa(i,3,1) = a1(i,3) * x
       aa(i,4,1) = a1(i,4) * y
       aa(i,3,2) = a1(i,3)
       aa(i,4,2) = a1(i,4)
       aa(i,1,2) = a1(i,1) * y
       aa(i,2,2) = a1(i,2) * x
    end do

  end subroutine coefft

  ! **********************************************************************
  ! In the limits of no scattering ( Fu, 1991 ), fk1 = 1.0 / u(3) and
  ! fk2 = 1.0 / u(4).
  ! **********************************************************************
  subroutine coefft0( solar,t0,t1,u0,f0,aa,zz,a1,z1,fk1,fk2)

    logical, intent (in) :: solar
    real, intent(in)     :: t0, t1, u0, f0
    real, intent (out)   :: aa(4,4,2), zz(4,2), a1(4,4), z1(4), fk1, fk2

    integer :: i, j, k, jj
    real    :: x, y, dt, fw

    fk1 = 4.7320545
    fk2 = 1.2679491
    y = exp ( - ( t1 - t0 ) / u0 )
    fw = 0.5 * f0
    do i = 1, 4
       if ( solar ) then
          z1(i) = 0.0
          zz(i,1) = 0.0
          zz(i,2) = 0.0
       else
          jj = 5 - i
          z1(i) = fw / ( 1.0 + u(jj) / u0 )
          zz(i,1) = z1(i)
          zz(i,2) = z1(i) * y
       endif
       do j = 1, 4
          a1(i,j) = 0.0
          do k = 1, 2
             aa(i,j,k) = 0.0
          end do
       end do
    end do
    do  i = 1, 4
       j = 5 - i
       a1(i,j) = 1.0
    end do
    dt = t1 - t0
    x = exp ( - fk1 * dt )
    y = exp ( - fk2 * dt )
    aa(1,4,1) = y
    aa(2,3,1) = x
    aa(3,2,1) = 1.0
    aa(4,1,1) = 1.0
    aa(1,4,2) = 1.0
    aa(2,3,2) = 1.0
    aa(3,2,2) = x
    aa(4,1,2) = y

  end subroutine coefft0

  ! **********************************************************************
  ! In the solar band  asbs is the surface albedo, while in the infrared
  ! band asbs is  blackbody intensity emitted at the surface temperature
  ! times surface emissivity.  In this subroutine, the delta-four-stream
  ! is applied to nonhomogeneous atmospheres. See comments in subroutine
  ! 'qcfel' for array AB(13,4*n).
  ! **********************************************************************
  subroutine qccfe (solar,asbs,ee,t,w,w1,w2,w3,u0,f0,fk1,fk2,a4,g4,z4 )

    logical, intent (in)              :: solar
    real, intent (in)                 :: asbs, ee
    real, dimension (nv), intent (in) :: t, w, w1, w2, w3, u0, f0
    real, dimension (nv), intent (out):: fk1, fk2
    real, intent(out)                 :: a4(4,4,nv), g4(4,nv), z4(4,nv)

    integer :: i, j, k, m18, m28, n4, kf, j1, j2, j3, i1
    integer :: i2, i3, i8, m2, m1
    real    :: fu(4,4), wu(4), ab(13,4*nv), bx(4*nv), xx(4*nv)
    real    :: aa(4,4,2), zz(4,2), a1(4,4), z1(4), fw1, fw2, wn, v1, v2, v3

    n4 = 4*nv
    do i = 1, n4
       do j = 1, 13
          ab(j,i) = 0.0
       end do
    end do

    wn = w(1)
    if ( wn <= 1.0e-4 ) then
       call coefft0(solar,0.0,t(1),u0(1),f0(1),aa,zz,a1,z1,fk1(1),fk2(1))
    else
       if ( wn >= 0.999999 ) wn = 0.999999
       call coefft(solar,wn,w1(1),w2(1),w3(1),0.0,t(1),u0(1),f0(1), &
            aa,zz,a1,z1,fk1(1),fk2(1))
    endif
    do  i = 1, 4
       z4(i,1) = z1(i)
       do  j = 1, 4
          a4(i,j,1) = a1(i,j)
       end do
    end do
    do  i = 1, 2
       bx(i) = - zz(i+2,1)
       i8 = i + 8
       do j = 1, 4
          ab(i8-j,j) = aa(i+2,j,1)
       end do
    end do
    do i = 1, 4
       wu(i) = zz(i,2)
       do j = 1, 4
          fu(i,j) = aa(i,j,2)
       end do
    end do
    do k = 2, nv
       wn = w(k)
       if ( w(k) .le. 1.0e-4 ) then
          call coefft0(solar,t(k-1),t(k),u0(k),f0(k),aa,zz,a1,z1,fk1(k),fk2(k))
       else
          if ( wn .ge. 0.999999 ) wn = 0.999999
          call coefft(solar,wn,w1(k),w2(k),w3(k),t(k-1),t(k),u0(k),f0(k),  &
               aa,zz,a1,z1,fk1(k),fk2(k))
       endif
       do  i = 1, 4
          z4(i,k) = z1(i)
          do  j = 1, 4
             a4(i,j,k) = a1(i,j)
          end do
       end do
       kf = k + k + k + k
       i1 = kf - 5
       i2 = i1 + 3
       j1 = kf - 7
       j2 = j1 + 3
       i3 = 0
       do  i = i1, i2
          i3 = i3 + 1
          bx(i) = - wu(i3) + zz(i3,1)
          j3 = 0
          i8 = i + 8
          do  j = j1, j2
             j3 = j3 + 1
             ab(i8-j,j) = fu(i3,j3)
          end do
          j3 = 0
          do j = j2 + 1, j2 + 4
             j3 = j3 + 1
             ab(i8-j,j) = - aa(i3,j3,1)
          end do
       end do
       do  i = 1, 4
          wu(i) = zz(i,2)
          do j = 1, 4
             fu(i,j) = aa(i,j,2)
          end do
       end do
    end do
    if ( solar ) then
       v1 = 0.2113247 * asbs
       v2 = 0.7886753 * asbs
       v3 = asbs * u0(1) * f0(1) * exp ( - t(nv) / u0(1) )
    else
       v1 = 0.2113247 * ( 1.0 - ee )
       v2 = 0.7886753 * ( 1.0 - ee )
       v3 = asbs
    end if
    m1 = n4 - 1
    m2 = n4
    m18 = m1 + 8
    m28 = m2 + 8
    fw1 = v1 * wu(3)
    fw2 = v2 * wu(4)
    bx(m1) = - ( wu(1) - fw1 - fw2 - v3 )
    bx(m2) = - ( wu(2) - fw1 - fw2 - v3 )
    do j = 1, 4
       j1 = n4 - 4 + j
       fw1 = v1 * fu(3,j)
       fw2 = v2 * fu(4,j)
       ab(m18-j1,j1) = fu(1,j) - fw1 - fw2
       ab(m28-j1,j1) = fu(2,j) - fw1 - fw2
    end do
    call qcfel (ab, bx, xx)
    do k = 1, nv
       j = k + k + k + k - 4
       do i = 1, 4
          j = j + 1
          g4(i,k) = xx(j)
       end do
    end do

  end subroutine qccfe

  ! **********************************************************************
  ! 1. `qcfel' is the abbreviation of ` qiu constants for each layer'.
  ! 2. The inhomogeneous atmosphere is divided into n adjacent homogeneous
  !    layers where the  single scattering properties are constant in each
  !    layer and allowed to vary from one to another. Delta-four-stream is
  !    employed for each homogeneous layer. The boundary conditions at the
  !    top and bottom of the atmosphere,  together with  continuity condi-
  !    tions  at  layer interfaces lead to a system of algebraic equations
  !    from which 4*n unknown constants in the problom can be solved.
  ! 3. This subroutine is used for solving the 4*n unknowns of A *X = B by
  !    considering the fact that the coefficient matrix is a sparse matrix
  !    with the precise pattern in this special problom.
  ! 4. The method is not different in principle from the general scheme of
  !    Gaussian elimination with backsubstitution, but carefully optimized
  !    so as to minimize arithmetic operations.  Partial  pivoting is used
  !    to quarantee  method's numerical stability,  which will  not change
  !    the basic pattern of sparsity of the matrix.
  ! 5. Scaling special problems so as to make  its nonzero matrix elements
  !    have comparable magnitudes, which will ameliorate the stability.
  ! 6. a, b and x present A, B and X in A*X=B, respectively. and n4=4*n.
  ! 7. AB(13,4*n) is the matrix A in band storage, in rows 3 to 13; rows 1
  !    and 2 and other unset elements should be set to zero on entry.
  ! 8. The jth column of A is stored in the jth column of the array AB  as
  !    follows:
  !            AB(8+i-j,j) = A(i,j) for max(1,j-5) <= i <= min(4*n,j+5).
  !    Reversedly, we have
  !            A(ii+jj-8,jj) = AB(ii,jj).
  ! **********************************************************************
  subroutine qcfel(ab, b, x)

    real, intent (inout)  :: ab(13,4*nv),b(4*nv)
    real, intent (out)    :: x(4*nv)

    integer :: i, j, k, l, m, n1, n2, n3, n4, m1, m2, m3, m4
    integer :: k44, n44, m18, m28, m38, m48, m1f, im1, i0m1, i0, i0f, ifq
    real    :: xx, yy, t, p

    n4 = 4*nv
    do  k = 1, nv - 1
       k44 = 4 * k - 4
       do  l= 1, 4
          m1 = k44 + l
          p = 0.0
          do  i = 8, 14 - l
             if ( abs ( ab(i,m1) ) .gt. abs ( p ) ) then
                p = ab(i,m1)
                i0 = i
             endif
          end do
          i0m1 = i0 + m1
          m18 = m1 + 8
          if ( i0 /= 8 ) then
             do  j = m1, m1 + 8 - l
                i0f = i0m1 - j
                m1f = m18 - j
                t = ab(i0f,j)
                ab(i0f,j) = ab(m1f,j)
                ab(m1f,j) = t
             end do
             i0f = i0m1 - 8
             t = b(i0f)
             b(i0f) = b(m1)
             b(m1) = t
          end if
          yy = ab(8,m1)
          ab(8,m1) = 1.0
          do  j = m1 + 1, m1 + 8 - l
             m1f = m18 - j
             ab(m1f,j) = ab(m1f,j) / yy
          end do
          b(m1) = b(m1) / yy
          do i = 9, 14 - l
             xx = ab(i,m1)
             ab(i,m1) = 0.0
             im1 = i + m1
             do  j = m1 + 1, m1 + 8 - l
                ifq = im1 - j
                m1f = m18 - j
                ab(ifq,j) = ab(ifq,j) - ab(m1f,j) * xx
             end do
             ifq = im1 - 8
             b(ifq) = b(ifq) - b(m1) * xx
          end do
       end do
    end do
    n44 = n4 - 4
    do l = 1, 3
       m1 = n44 + l
       p = 0.0
       do i = 8, 12 - l
          if ( abs ( ab(i,m1) ) .gt. abs ( p ) ) then
             p = ab(i,m1)
             i0 = i
          endif
       end do
       i0m1 = i0 + m1
       m18 = m1 + 8
       if( i0 /= 8 ) then
          do  j = m1, m1 + 4 - l
             i0f = i0m1 - j
             m1f = m18 - j
             t = ab(i0f,j)
             ab(i0f,j) = ab(m1f,j)
             ab(m1f,j) = t
          end do
          i0f = i0m1 - 8
          t = b(i0f)
          b(i0f) = b(m1)
          b(m1) = t
       end if
       yy = ab(8,m1)
       ab(8,m1) = 1.0
       do  j = m1 + 1, m1 + 4 - l
          m1f = m18 - j
          ab(m1f,j) = ab(m1f,j) / yy
       end do
       b(m1) = b(m1) / yy
       do  i = 9, 12 - l
          xx = ab(i,m1)
          ab(i,m1) = 0.0
          im1 = i + m1
          do  j = m1 + 1, m1 + 4 - l
             ifq = im1 - j
             m1f = m18 - j
             ab(ifq,j) = ab(ifq,j) - ab(m1f,j) * xx
          end do
          ifq = im1 - 8
          b(ifq) = b(ifq) - b(m1) * xx
       end do
    end do
    yy = ab(8,n4)
    ab(8,n4) = 1.0
    b(n4) = b(n4) / yy
    n3 = n4 - 1
    n2 = n3 - 1
    n1 = n2 - 1
    x(n4) = b(n4)
    x(n3) = b(n3) - ab(7,n4) * x(n4)
    x(n2) = b(n2) - ab(7,n3) * x(n3) - ab(6,n4) * x(n4)
    x(n1) = b(n1) - ab(7,n2) * x(n2) - ab(6,n3) * x(n3) - ab(5,n4) * x(n4)
    do  k = 1, nv - 1
       m4 = 4 * ( nv - k )
       m3 = m4 - 1
       m2 = m3 - 1
       m1 = m2 - 1
       m48 = m4 + 8
       m38 = m3 + 8
       m28 = m2 + 8
       m18 = m1 + 8
       x(m4) = b(m4)
       do  m = m4 + 1, m4 + 4
          x(m4) = x(m4) - ab(m48-m,m) * x(m)
       end do
       x(m3) = b(m3)
       do  m = m3 + 1, m3 + 5
          x(m3) = x(m3) - ab(m38-m,m) * x(m)
       end do
       x(m2) = b(m2)
       do  m = m2 + 1, m2 + 6
          x(m2) = x(m2) - ab(m28-m,m) * x(m)
       end do
       x(m1) = b(m1)
       do  m = m1 + 1, m1 + 7
          x(m1) = x(m1) - ab(m18-m,m) * x(m)
       end do
    end do

  end subroutine qcfel

  ! **********************************************************************
  ! In this subroutine, we incorporate a delta-function adjustment to
  ! account for the  forward  diffraction  peak in the context of the
  ! four-stream approximation ( Liou, Fu and Ackerman, 1988 ). w1(n),
  ! w2(n), w3(n), w(n), and t(n) are the adjusted parameters.
  ! **********************************************************************
  subroutine adjust (tt,ww,ww1,ww2,ww3,ww4,t,w,w1,w2,w3)

    real, dimension (nv), intent (in) :: tt,ww,ww1,ww2,ww3,ww4
    real, dimension (nv), intent (out):: t,w,w1,w2,w3

    integer :: k
    real    :: tt0, f, fw, dt(nv)

    tt0 = 0.0;f = 0.0; fw = 0.0; dt = 0.0; k = 0
    do  k = 1, nv
       f = ww4(k) / 9.0
       fw = 1.0 - f * ww(k)
       w1(k) = ( ww1(k) - 3.0 * f ) / ( 1.0 - f )
       w2(k) = ( ww2(k) - 5.0 * f ) / ( 1.0 - f )
       w3(k) = ( ww3(k) - 7.0 * f ) / ( 1.0 - f )
       w(k) = ( 1.0 - f ) * ww(k) / fw
       dt(k) = (tt(k) - tt0) * fw
       tt0 = tt(k)
    end do
    t(1) = dt(1)
    do k = 2, nv
       t(k) = dt(k) + t(k-1)
    end do

  end subroutine adjust
  ! --------------------------------------------------------------------------
  ! Subroutine qft: Delta 4-stream solver for fluxes
  !
  subroutine qft (solar, ee, as, u0, bf, tt, ww, ww1, ww2, ww3, ww4, ffu, ffd)

    logical, intent (in) :: solar
    real, intent (in)    :: ee, as, u0
    real, dimension (nv), intent (in)   :: tt,ww,ww1,ww2,ww3,ww4
    real, dimension (nv1), intent (in)  :: bf
    real, dimension (nv1), intent (out) :: ffu, ffd

    real, dimension (nv) :: t,w,w1,w2,w3,u0a,f0a,fk1,fk2
    integer :: k, kk, ii, jj
    real    :: x(4), fi(4), a4(4,4,nv), z4(4,nv), g4(4,nv)
    real    :: tkm1, fw3, fw4, y1, xy, xas, xee
    real, parameter :: fw1 = 0.6638960, fw2 = 2.4776962
    t = 0.0; w = 0.0; w1 = 0.0; w2 = 0.0; w3 = 0.0; u0a = 0.0; f0a = 0.0; fk1 = 0.0; fk2 = 0.0;

    call adjust(tt,ww,ww1,ww2,ww3,ww4,t,w,w1,w2,w3)

    if (solar) then
       fw3 = u0
       xee = 0.0
       xas = as
       do k = 1, nv
          u0a(k) = u0
          f0a(k) = 1./pi
       end do
    else
       fw3 = 0.
       xas = bf(nv1) * ee
       xee = ee
       tkm1 = 0.0
       do k = 1, nv
          f0a(k) = 2.0 * ( 1.0 - w(k) ) * bf(k)
          u0a(k) = -(t(k)-tkm1) / ( alog( bf(k+1)/bf(k) ) + epsilon(1.))
          tkm1 = t(k)
       end do
    end if
    call qccfe (solar,xas,xee,t,w,w1,w2,w3,u0a,f0a,fk1,fk2,a4,g4,z4 )

    tkm1 = 0.
    do k = 1, nv1
       if ( k == 1 ) then
          x(1) = 1.0
          x(2) = 1.0
          x(3) = exp ( - fk1(1) * t(1) )
          x(4) = exp ( - fk2(1) * t(1) )
          kk = 1
          xy = 1.0
       else
          kk = k - 1
          y1 = t(kk) - tkm1
          x(1) = exp ( - fk2(kk) * y1 )
          x(2) = exp ( - fk1(kk) * y1 )
          x(3) = 1.0
          x(4) = 1.0
          if (solar) y1 = t(kk)
          xy =  exp ( - y1 / u0a(kk) )
       endif
       if (kk > 1) tkm1 = t(kk)

       do  jj = 1, 4
          fi(jj) = z4(jj,kk) * xy
       end do
       do ii = 1, 4
          fw4 = g4(ii,kk) * x(ii)
          do jj = 1, 4
             fi(jj) = fi(jj) + a4(jj,ii,kk) * fw4
          end do
       end do

       ffu(k)= fw1 * fi(2) + fw2 * fi(1)
       ffd(k)= fw1 * fi(3) + fw2 * fi(4)  + fw3 * xy
    end do

  end subroutine qft

end module solver


c     # ------------------------------------------------------------
c     # Compute edge centered and cell-centered velocity fields
c     #
c     # Edge : Compute velocity from a stream function.
c     # This defines the average velocity at each edge
c     #
c     #      u = curl \Psi  (div u = 0)
c     #
c     # Center : Defines cell-centered velocities from a streamfunction
c     #
c     #      u = n cross grad \Psi  (div u = 0)
c     #
c     # or using basis functions
c     #
c     #      u = u1*tau1 + u2*tau2   (div u might not be zero)
c     #
c     # NOTE: All arguments to routines here should be in computational
c     # coordinates (xi,eta) in [0,1]x[0,1].  Mapping from brick domains
c     # to [0,1]x[0,1] should be done from calling routines.
c     # ------------------------------------------------------------

c     # ------------------------------------------------------------
c     # Edge : u = \nabla cross \Psi - curl \Psi
c     # ------------------------------------------------------------
      subroutine torus_edge_velocity(xc1,yc1,xc2,yc2,ds,vn)
      implicit none

      double precision xc1,yc1,xc2,yc2, ds, vn, torus_psi

      vn = (torus_psi(xc1,yc1) - torus_psi(xc2,yc2))/ds

      end

c     # ------------------------------------------------------------
c     # Center : u = n cross grad \Psi   (div u = 0)
c     #
c     # Center : u = u1*tau1 + u2*tau2   (div u might not be zero)
c     # ------------------------------------------------------------
      subroutine torus_center_velocity(xc1,yc1,vel)
      implicit none

      double precision xc1,yc1,vel(3)

      double precision tau1(3), tau2(3)
      double precision tau1inv(3), tau2inv(3)
      double precision nvec(3), gradpsi(3), sv
      logical use_stream

      double precision psi_xi, psi_eta
      double precision u1, u2, coderiv1(2), coderiv2(2)

      double precision pi
      common /compi/ pi

      integer example
      common /example_comm/ example

      integer k

      use_stream = .false.

      if (example .eq. 0 .and. use_stream) then
c         # Divergence free velocity field : u = n cross \Psi
          call torus_psi_derivs(xc1,yc1,psi_xi,psi_eta)

          call torus_contravariant_basis(xc1,yc1, tau1inv,tau2inv)

          do k = 1,3
              gradpsi(k) = psi_xi*tau1inv(k) + psi_eta*tau2inv(k)
          end do

c         # Get surface normal
          call torus_covariant_basis(xc1,yc1,tau1,tau2)

c         Outward directed normal
          call torus_cross(tau2,tau1,nvec,sv)

c         # Normalize surface normal
          do k = 1,3
              nvec(k) = nvec(k)/sv
          end do

c         # v = nvec x grad \Psi
          call torus_cross(nvec,gradpsi,vel,sv)
      else
c         # Vector field defined as u1*tau1 + u2*tau2

          call torus_covariant_basis(xc1, yc1, tau1,tau2)
          call torus_velocity_components(xc1,yc1,u1,u2, coderiv1,
     &                                   coderiv2)

          do k = 1,3
              vel(k) = u1*tau1(k) + u2*tau2(k)
          enddo
      endif

      end

c     # ----------------------------------------------------------------
c     # Mapping functions
c     #
c     # Covariant basis vectors       : tau1 = T_xi, tau2 = T_eta
c     #
c     # Contravariant basis vectors   : tau1inv = a^{11}T_xi + a^{12}T_eta
c     #                                 tau2inv = a^{21}T_xi + a^{22}T_eta
c     #
c     # Christoffel symbols           : g111, g112, g212, g222 (needed for
c     #                                 computation of the divergence)
c     #
c     # Mapping function depends on these global variables
c     #
c     #         mapping (0=torus; 1=twisted torus)
c     # ----------------------------------------------------------------

      subroutine torus_covariant_basis(xc1,yc1,tau1,tau2)
      implicit none

      double precision xc1, yc1
      double precision tau1(3), tau2(3)

      double precision R, Reta, Rxi

      double precision pi, pi2
      common /compi/ pi

      double precision alpha
      common /torus_comm/ alpha

      integer mapping
      common /mapping_comm/ mapping

      pi2 = 2*pi

      if (mapping .eq. 0) then
          R = 1 + alpha*cos(pi2*yc1)
          Reta = -pi2*alpha*sin(pi2*yc1)

c         # T_xi
          tau1(1) = -pi2*R*sin(pi2*xc1)
          tau1(2) = pi2*R*cos(pi2*xc1)
          tau1(3) = 0

c         # T_eta
          tau2(1) = Reta*cos(pi2*xc1)
          tau2(2) = Reta*sin(pi2*xc1)
          tau2(3) = pi2*alpha*cos(pi2*yc1)

      elseif (mapping .eq. 1) then
c         # Coordinate normals
          R    = 1 +  alpha*cos(pi2*(xc1 + yc1))
          Rxi  = -pi2*alpha*sin(pi2*(xc1 + yc1))
          Reta = -pi2*alpha*sin(pi2*(xc1 + yc1))

c         # T_xi
          tau1(1) = Rxi*cos(pi2*xc1) - pi2*R*sin(pi2*xc1)
          tau1(2) = Rxi*sin(pi2*xc1) + pi2*R*cos(pi2*xc1)
          tau1(3) = pi2*alpha*cos(pi2*(xc1 + yc1))

c         # T_eta
          tau2(1) = Reta*cos(pi2*xc1)
          tau2(2) = Reta*sin(pi2*xc1)
          tau2(3) = pi2*alpha*cos(pi2*(xc1+yc1))
      endif

      end

      subroutine torus_contravariant_basis(xc1,yc1, tau1inv, tau2inv)
      implicit none

      double precision xc1,yc1

      double precision tau1(3), tau2(3)
      double precision a11, a22, a12, a21, det
      double precision a11inv, a22inv, a12inv, a21inv
      double precision tau1inv(3), tau2inv(3)
      double precision torus_dot

      integer k

      call torus_covariant_basis(xc1,yc1, tau1,tau2)

c     # Compute grad psi(xi,eta)
      a11 = torus_dot(tau1,tau1)
      a22 = torus_dot(tau2,tau2)
      a12 = torus_dot(tau1,tau2)
      a21 = a12

c     # Determinant
      det = a11*a22 - a12*a21

c     # Contravariant vectors
      a11inv = a22/det
      a22inv = a11/det
      a12inv = -a12/det
      a21inv = -a21/det
      do k = 1,3
          tau1inv(k) = a11inv*tau1(k) + a12inv*tau2(k)
          tau2inv(k) = a21inv*tau1(k) + a22inv*tau2(k)
      end do

      end

cc     # Derivative in direction x^i = (xi, eta)
      subroutine torus_covariant_derivative(xc1,yc1,j,u1,u2,
     &                                  u1j,u2j,coderiv)
      implicit none

      double precision xc1, yc1, u1,u2, u1j, u2j, coderiv(2)
      integer j

      double precision g111,g112,g211,g212
      double precision g121,g122,g221,g222
      double precision torus_christoffel_sym

      double precision u11, u12, u21, u22

c      call torus_velocity_components(xc1,yc1,u1,u2,u11,u22,u12,u21)

c     # Christoffel symbol gijk
c     # i - component  (u1 or u2)
c     # j - derivative (xi or eta)
c     # k - dummy variable
      if (j .eq. 1) then
          u11 = u1j
          u21 = u2j
          g111 = torus_christoffel_sym(xc1,yc1,1,1,1)
          g112 = torus_christoffel_sym(xc1,yc1,1,1,2)
          coderiv(1) = u11 + (u1*g111 + u2*g112)

          g211 = torus_christoffel_sym(xc1,yc1,2,1,1)
          g212 = torus_christoffel_sym(xc1,yc1,2,1,2)
          coderiv(2) = u21 + (u1*g211 + u2*g212)

c          write(6,100) coderiv(1), coderiv(2)
      else
          u12 = u1j
          u22 = u2j
          g121 = torus_christoffel_sym(xc1,yc1,1,2,1)
          g122 = torus_christoffel_sym(xc1,yc1,1,2,2)
          coderiv(1) = u12 + (u1*g121 + u2*g122)

          g221 = torus_christoffel_sym(xc1,yc1,2,2,1)
          g222 = torus_christoffel_sym(xc1,yc1,2,2,2)
          coderiv(2) = u22 + (u1*g221 + u2*g222)

c          write(6,100) coderiv(1), coderiv(2)
c          write(6,100) g121, g221
      endif

100   format(3F24.16)
      end

      double precision function torus_christoffel_sym(xc1,yc1,i,j,k)
      implicit none

      double precision xc1, yc1
      integer i,j,k
      double precision gijk

      double precision T1(3), T2(3)
      double precision T11(3), T22(3), T12(3), T21(3)
      double precision gi(3), gjk(3)

      double precision R, R2, R22
      double precision torus_dot

      double precision pi, pi2
      common /compi/ pi

      double precision alpha
      common /torus_comm/ alpha

      integer mapping
      common /mapping_comm/ mapping

      integer kk

      pi2 = 2*pi

      if (mapping .eq. 0) then
          R   = 1 + alpha*cos(pi2*yc1)
          R2  = -pi2*alpha*sin(pi2*yc1)
          R22 = -pi2**2*alpha*cos(pi2*yc1)

cc        # T_xi
c         T1(1) = -pi2*R*sin(pi2*xc1)
c         T1(2) = pi2*R*cos(pi2*xc1)
c         T1(3) = 0

cc        # T_eta
c         T2(1) = Reta*cos(pi2*xc1)
c         T2(2) = Reta*sin(pi2*xc1)
c         T2(3) = pi2*alpha*cos(pi2*yc1)

          T11(1) = -pi2**2*R*cos(pi2*xc1)
          T11(2) = -pi2**2*R*sin(pi2*xc1)
          T11(3) = 0

          T12(1) = -pi2*R2*sin(pi2*xc1)
          T12(2) =  pi2*R2*cos(pi2*xc1)
          T12(3) = 0

          T21(1) = -pi2*R2*sin(pi2*xc1)
          T21(2) =  pi2*R2*cos(pi2*xc1)
          T21(3) = 0

          T22(1) = R22*cos(pi2*xc1)
          T22(2) = R22*sin(pi2*xc1)
          T22(3) = 0
      elseif (mapping .eq. 1) then
c         # To do ....
      endif

      call torus_covariant_basis(xc1,yc1,T1,T2)

      do kk = 1,3
          if (i .eq. 1) then
              gi(kk) = T1(kk)
          else
              gi(kk) = T2(kk)
          endif

          if (j .ne. k) then
              if (j .eq. 1) then
                  gjk(kk) = T12(kk)
              else
                  gjk(kk) = T21(kk)
              endif
          else
              if (j .eq. 1) then
c                 # j == k == 1
                  gjk(kk) = T11(kk)
              else
c                 # j == k == 2
                  gjk(kk) = T22(kk)
              endif
          endif
      end do

      gijk = torus_dot(gi,gjk)

      torus_christoffel_sym = gijk

      end

      double precision function torus_divergence(xc1,yc1)
      implicit none

      double precision xc1,yc1

      double precision divu, u1, u2, coderiv1(2), coderiv2(2)

c      call torus_covariant_derivative(xc1,yc1,1,coderiv1)
c      call torus_covariant_derivative(xc1,yc1,2,coderiv2)

      call torus_velocity_components(xc1,yc1,u1,u2,coderiv1,
     &                                     coderiv2)

      torus_divergence = coderiv1(1) + coderiv2(2)

      end

c     # ----------------------------------------------------------------
c     # RHS functions for ODE solver DOPRI5  (original ode45)
c     #        -- divfree field
c     #        -- field with divergence
c     # ----------------------------------------------------------------

      subroutine torus_rhs_divfree(n,t,sigma,f,rpar,ipar)
      implicit none

      integer n, ipar
      double precision t, sigma(n), f(n), rpar

      integer m, i
      double precision xc1,yc1, q, u1,u2
      double precision psi_xi, psi_eta
      double precision tau1(3), tau2(3), t1xt2(3), w

      xc1 = sigma(1)
      yc1 = sigma(2)

      call torus_covariant_basis(xc1,yc1,tau1,tau2)
      call torus_psi_derivs(xc1,yc1,psi_xi,psi_eta)

c     # Compute u dot grad q in computational coordinates
      call torus_cross(tau1,tau2,t1xt2,w);

c     # Evolve contravariant components of velocity field
      u1 = -psi_eta/w
      u2 = psi_xi/w

c     # This is a clockwise velocity field ?
      f(1) = u1
      f(2) = u2

      end

      subroutine torus_rhs_nondivfree(n,t,sigma,f,rpar,ipar)
      implicit none

      integer n, ipar
      double precision t, sigma(n), f(n), rpar

      double precision xc1,yc1, q
      double precision u1,u2,u11,u22
      double precision divu, torus_divergence
      double precision coderiv1(2), coderiv2(2)

c     # Track evolution of these three quantities
      xc1 = sigma(1)
      yc1 = sigma(2)
      q = sigma(3)

      call torus_velocity_components(xc1,yc1,u1,u2,coderiv1,coderiv2)

      divu = coderiv1(1) + coderiv2(2)
      if (abs(divu) .gt. 1e-10) then
c          write(6,100) coderiv1(1), coderiv2(2), divu
      endif
100   format(3F24.16)

      f(1) = u1
      f(2) = u2
      f(3) = -divu*q   !! Non-conservative case

      end

c     # ----------------------------------------------------------------
c     # Utility functions
c     # ----------------------------------------------------------------

      subroutine torus_cross(u,v,uxv,w)
      implicit none

      double precision u(3),v(3),uxv(3),w, torus_dot
      integer k

      uxv(1) =   u(2)*v(3) - u(3)*v(2)
      uxv(2) = -(u(1)*v(3) - u(3)*v(1))
      uxv(3) =   u(1)*v(2) - u(2)*v(1)

      w =  torus_dot(uxv,uxv)
      w = sqrt(w)

      end

      double precision function torus_dot(u,v)
      implicit none

      double precision u(3),v(3)

      torus_dot = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)

      end


module type_gmres
#include <messenger.h>
    use mod_kinds,              only: rk, ik
    use mod_constants,          only: DIAG, ZERO, TWO
    use mod_inv,                only: inv
    use atype_matrixsolver,     only: matrixsolver_t
    use type_preconditioner,    only: preconditioner_t
    use type_blockmatrix,       only: blockmatrix_t
    use type_densematrix,       only: densematrix_t
    use type_blockvector
    use operator_mv
    use operator_dot,           only: dot

    implicit none

    !> Generalized Minimum Residual linear system solver
    !!
    !!  @author Nathan A. Wukie
    !!
    !-------------------------------------------
    type, public, extends(matrixsolver_t) :: gmres_t

        integer(ik) :: m = 1000

    contains

        procedure   :: solve
    end type gmres_t

contains

    !> Solution routine
    !!
    !!  @author Nathan A. Wukie
    !!
    !!
    !!
    !--------------------------------------------------------------
    subroutine solve(self,A,x,b,M)
        class(gmres_t),             intent(inout)               :: self
        type(blockmatrix_t),        intent(inout)               :: A
        type(blockvector_t),        intent(inout)               :: x
        type(blockvector_t),        intent(inout)               :: b
        class(preconditioner_t),    intent(inout), optional     :: M

        type(blockvector_t)                     :: r, r0, diff, xold, w, x0
        type(blockvector_t), allocatable        :: v(:)
        real(rk),            allocatable        :: h(:,:), h_square(:,:)
        real(rk),            allocatable        :: p(:), y(:), c(:), s(:), p_dim(:), y_dim(:)
        real(rk)                                :: pj, pjp, h_ij, h_ipj

        integer(ik) :: iparent, ierr, ivec, isol, nvecs
        integer(ik) :: i, j, k, l                 ! Loop counters
        real(rk)    :: res, err, r0norm, gam

        logical     :: converged = .false.
        logical     :: max_iter  = .false.

        !
        ! Start timer
        !
        call self%timer%reset()
        call self%timer%start()
        print*, '           Matrix Solver: '

        !
        ! Allocate and initialize Krylov vectors V
        !
        allocate(v(self%m+1),stat=ierr)
        if (ierr /= 0) call AllocationError

        do ivec = 1,size(v)
            v(ivec) = b
            call v(ivec)%clear()
        end do

        !
        ! Allocate hessenberg matrix to store orthogonalization
        !
        allocate(h(self%m + 1, self%m), stat=ierr)
        if (ierr /= 0) call AllocationError
        h = ZERO

        !
        ! Allocate vectors for solving hessenberg system
        !
        allocate(p(self%m+1), &
                 y(self%m+1), &
                 c(self%m+1), &
                 s(self%m+1), stat=ierr)
        if (ierr /= 0) call AllocationError
        p = ZERO
        y = ZERO
        c = ZERO
        s = ZERO

        !
        ! Set initial solution x. ZERO
        !
        x0 = x
        call x0%clear()
        call x%clear()

        !
        ! Compute initial residual r0, residual norm, and normalized r0
        !
        r0      = self%residual(A,x,b)
        v(1)    = r0/r0%norm()

        p(1) = r0%norm()
        !
        ! Outer GMRES Loop
        !
        nvecs = 0
        do j = 1,self%m
            nvecs = nvecs + 1

            !
            ! Compute w = Av for the current iteration
            !
            w = A*v(j)

            !
            ! Orthogonalization loop
            !
            do i = 1,j

                h(i,j) = dot(w,v(i))

                w  = w - h(i,j)*v(i)

            end do  ! Inner GMRES Loop - i

            h(j+1,j) = w%norm()

            !
            ! Compute next Krylov vector
            !
            v(j+1) = w/h(j+1,j)

            !
            ! Previous Givens rotations on h
            !
            if (j /= 1) then
                do i = 1,j-1
                    ! Need temp values here so we don't directly overwrite the h(i,j) and h(i+1,j) values
                    h_ij     = c(i)*h(i,j)  +  s(i)*h(i+1,j)
                    h_ipj    = -s(i)*h(i,j)  +  c(i)*h(i+1,j)

                    h(i,j)    = h_ij
                    h(i+1,j)  = h_ipj
                end do
            end if

            !
            ! Compute next rotation
            !
            gam  = sqrt( h(j,j)*h(j,j)  +  h(j+1,j)*h(j+1,j) )
            c(j) = h(j,j)/gam
            s(j) = h(j+1,j)/gam

            !
            ! Givens rotation on h
            !
            h(j,j)   = gam
            h(j+1,j) = ZERO

            !
            ! Givens rotation on p. Need temp values here so we aren't directly overwriting the p(j) value until we want to
            !
            pj = c(j)*p(j)
            pjp = -s(j)*p(j)

            p(j)     = pj
            p(j+1)   = pjp

            !
            ! Test exit conditions
            !
            print*, 'resid'
            print*, abs(p(j+1))
            converged = (abs(p(j+1)) < self%tol)

            if ( converged ) then
                exit
            end if

        end do  ! Outer GMRES Loop - j

        !
        ! Solve upper-triangular system y = hinv * p
        !
        allocate(h_square(nvecs,nvecs), &
                 p_dim(nvecs),      &
                 y_dim(nvecs), stat=ierr)
        if (ierr /= 0) call AllocationError

        ! Store h and p values to appropriately sized matrices
        print*, j
        do l=1,nvecs
            do k=1,nvecs
                h_square(k,l) = h(k,l)
            end do
            p_dim(l) = p(l)
        end do

        ! Solve the system
        h_square = inv(h_square)
        y_dim = matmul(h_square,p_dim)

        !
        ! Reconstruct solution
        !
        x = x0
        do isol = 1,nvecs
            x = x + y_dim(isol)*v(isol)
        end do

        err = self%error(A,x,b)
        print*, '   Matrix Solver Error: ', err

        !
        ! Report timings
        !
        call self%timer%stop()
        call self%timer%report('Matrix solver compute time: ')

    end subroutine solve

end module type_gmres


    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    CompFunctionNorm.f90
    !> \brief   Compute the functional norm for the line search.
    !> \author  M.H.A. Piro
    !> \date    Apr. 25, 2012
    !> \sa      GEMLineSearch.f90
    !> \sa      CompStoichSolnPhase.f90
    !
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   04/25/2012      M.H.A. Piro         Original code
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to compute the functional norm for the line search algorithm to
    !! determine whether the system is converging sufficinetly or diverging. The functional vector is not directly
    !! computed because it is not needed. Thus, the functional norm is computed directly.  This term incorporates
    !! the residuals of the mass balance equations, the average residual between the chemical potential of each
    !! species and the corresponding value computed from the element potentials.
    !
    !
    ! Pertinent variables:
    ! ====================
    !
    ! dGEMFunctionNorm      A double real scalar representing the functional norm of the functional  vector.  The
    !                        functional vector represents the relative errors of the mass balance equations,
    !                        the departure of chemical potentials of stable phases from the corresponding values
    !                        computed from the element potentials.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine CompFunctionNorm

    USE ModuleThermo
    USE ModuleGEMSolver

    implicit none

    integer :: i, j, k, l
    real(8) :: dTemp, dTempB

    ! Initialize variables:
    dGEMFunctionNorm    = 0D0
    dEffStoichSolnPhase = 0D0

    ! Compute the residuals of the mass balance equations for each element:
    do j = 1, nElements
        dTemp = dMolesElement(j)

        do i = 1, nSolnPhases
            k = -iAssemblage(nElements - i + 1)       ! Absolute solution phase index

            ! Compute the stoichiometry of this solution phase:
            call CompStoichSolnPhase(k)

            dTemp = dTemp - dEffStoichSolnPhase(k,j) * dMolesPhase(nElements - i + 1)

        end do

        do i = 1,nConPhases
            dTemp = dTemp - dMolesPhase(i) * dStoichSpecies(iAssemblage(i),j)
        end do

        dGEMFunctionNorm = dGEMFunctionNorm + (dTemp)**(2)

    end do

    ! Compute the residuals of the Gibbs energy difference between each solution phase and the element potentials:
    do l = 1, nSolnPhases
        k      = -iAssemblage(nElements - l + 1)       ! Absolute solution phase index
        dTempB = 0D0

        do i = nSpeciesPhase(k-1) + 1, nSpeciesPhase(k)
            dTemp = 0D0
            do j = 1, nElements
                dTemp = dTemp + dElementPotential(j) * dStoichSpecies(i,j)
            end do

            ! Normalize the residual term by the number of particles per formula mass:
            dTemp = dTemp / DFLOAT(iParticlesPerMole(i))

			! Compute the residual term weighted by the mole fraction:
            dTemp = DABS(dChemicalPotential(i) - dTemp) * dMolFraction(i)

            ! Exclude trace species from the computation of the functional norm:
            dTempB = dTempB + dTemp

        end do

        dGEMFunctionNorm = dGEMFunctionNorm + (dTempB)**(2)

    end do

    ! Compute the residuals of the chemical potentials of pure condensed phases and the element potentials:
    do i = 1, nConPhases
        k     = iAssemblage(i)
        dTemp = 0D0

        do j = 1, nElements
            dTemp = dTemp + dElementPotential(j) * dStoichSpecies(k,j)
        end do

        dTemp            = dTemp - dStdGibbsEnergy(k)
        dGEMFunctionNorm = dGEMFunctionNorm + (dTemp)**(2)

    end do

    ! Finally, the functional norm:
    dGEMFunctionNorm = dGEMFunctionNorm**(0.5)

    if (lDebugMode .EQV. .TRUE.) print *, 'dGEMFunctionNorm = ', dGEMFunctionNorm

    return

end subroutine CompFunctionNorm


SUBROUTINE REC_WRITE_MATRIX_C(A,A_dim1,A_dim2)
  ! it writes a matrix of doubles nxm on the screen
  USE SUBINTERFACE_LAPACK
  INTEGER, INTENT(IN) :: A_dim1,A_dim2
  DOUBLE PRECISION, DIMENSION(A_dim1*A_dim2),intent(in) :: A

  INTEGER I,J
  DOUBLE PRECISION, DIMENSION(A_dim1,A_dim2) :: A_FORTRAN

  write(*,*) 'fortan says: ',A_DIM

  DO I=1,A_DIM1
     DO J = 1,A_DIM2
        A_FORTRAN(I,J) = A(I+(J-1)*A_DIM1)
     END DO
  END DO

  CALL WRITE_MATRIX(A_FORTRAN)

END SUBROUTINE REC_WRITE_MATRIX_C

SUBROUTINE WRITE_MATRIX_C(A,A_dim)
  ! it writes a matrix of doubles nxm on the screen
  USE SUBINTERFACE_LAPACK
  INTEGER, INTENT(IN) :: A_dim
  DOUBLE PRECISION, DIMENSION(A_dim*A_dim),intent(in) :: A

  INTEGER I,J
  DOUBLE PRECISION, DIMENSION(A_dim,A_dim) :: A_FORTRAN

  !write(*,*) 'fortan says: ',A_DIM

  DO I=1,A_DIM
     DO J = 1,A_DIM
        A_FORTRAN(I,J) = A(I+(J-1)*A_DIM)
     END DO
  END DO

  CALL WRITE_MATRIX(A_FORTRAN)

END SUBROUTINE WRITE_MATRIX_C

SUBROUTINE WRITE_MATRIX_INT_C(A,A_dim)
  !it writes a matrix of integer nxm on the screen
  USE SUBINTERFACE_LAPACK
  INTEGER, INTENT(IN) :: A_dim
  DOUBLE PRECISION, DIMENSION(A_dim),intent(in) :: A

  INTEGER I,J
  INTEGER, DIMENSION(A_dim,A_dim) :: A_FORTRAN

  DO I=1,A_DIM
     DO J = 1,A_DIM
        A_FORTRAN(I,J) = A(I+(J-1)*A_DIM)
     END DO
  END DO

  CALL WRITE_MATRIX_INT(A_FORTRAN)
END SUBROUTINE WRITE_MATRIX_INT_C

SUBROUTINE COORDINATEPACKING_C(D,A,V,R,C,index,INFO)
  IMPLICIT NONE
  INTEGER,INTENT(IN):: D
  COMPLEX*16,DIMENSION(D,D),INTENT(IN)  :: A
  COMPLEX*16,DIMENSION(D*D),INTENT(OUT) :: V
  INTEGER, DIMENSION(D*D),  INTENT(OUT) :: R,C
  INTEGER, INTENT(OUT)   :: index
  INTEGER, INTENT(INOUT) :: INFO

  CALL COORDINATEPACKING(D,A,V,R,C,index,INFO)

END SUBROUTINE COORDINATEPACKING_C

MODULE MERGINGARRAYS_C
  INTERFACE
     SUBROUTINE APPENDARRAYS_C(V,B,INFO)
       COMPLEX*16, DIMENSION(:),ALLOCATABLE, INTENT(INOUT) :: V
       COMPLEX*16, DIMENSION(:),INTENT(IN)    :: B
       INTEGER,                 INTENT(INOUT) :: INFO
     END SUBROUTINE APPENDARRAYS_C
     SUBROUTINE APPENDARRAYSI_C(V,B,INFO)
       INTEGER, DIMENSION(:),ALLOCATABLE, INTENT(INOUT) :: V
       INTEGER, DIMENSION(:),INTENT(IN)    :: B
       INTEGER,                 INTENT(INOUT) :: INFO
     END SUBROUTINE APPENDARRAYSI_C
  END INTERFACE
END MODULE MERGINGARRAYS_C

SUBROUTINE APPENDARRAYS_C(V,B,INFO)
  COMPLEX*16, DIMENSION(:),ALLOCATABLE, INTENT(INOUT) :: V
  COMPLEX*16, DIMENSION(:),INTENT(IN)    :: B
  INTEGER,                 INTENT(INOUT) :: INFO

  CALL APPENDARRAYS(V,B,INFO)

END SUBROUTINE APPENDARRAYS_C

SUBROUTINE APPENDARRAYSI_C(V,B,INFO)
  INTEGER, DIMENSION(:),ALLOCATABLE, INTENT(INOUT) :: V
  INTEGER, DIMENSION(:),INTENT(IN)    :: B
  INTEGER,                 INTENT(INOUT) :: INFO

  COMPLEX*16,DIMENSION(:),ALLOCATABLE :: tmp_arr

  CALL APPENDARRAYSI(V,B,INFO)

END SUBROUTINE APPENDARRAYSI_C

!SUBROUTINE MATMUL_C(OP_LENGHT,OP,A,RA,CA,B,RB,CB,C,INFO)
SUBROUTINE MATMUL_C(OP,A,RA,CA,B,RB,CB,C,INFO)

  IMPLICIT NONE
  !INTEGER, INTENT(IN):: RA,CA,RB,CB,OP_LENGHT
  !CHARACTER(OP_LENGHT), INTENT(IN) :: OP
  INTEGER, INTENT(IN):: RA,CA,RB,CB,OP

  COMPLEX*16, DIMENSION(RA,CA), INTENT(IN)::A
  COMPLEX*16, DIMENSION(RB,CB), INTENT(IN)::B
  COMPLEX*16, DIMENSION(RA,CB), INTENT(INOUT)::C
  INTEGER, INTENT(INOUT):: INFO

  !write(*,*) abs(A)**2
  !write(*,*) abs(B)**2
  !write(*,*) op
  SELECT CASE (OP)

     !CASE("T")
  CASE(1)
     IF(RA.EQ.RB) THEN
        C = MATMUL(TRANSPOSE(A),B)
     ELSE
        C = 0.0
        INFO = -1
        WRITE(*,*) 'ERROR, INCONSISTENCY WITH THE DIMENSIONS OF THE MATRICES'
     END IF

  !CASE("TC")
  CASE(2)

     !WRITE(*,*) "TC"
     IF(RA.EQ.RB) THEN
        C = MATMUL(TRANSPOSE(CONJG(A)),B)
     ELSE
        C = 0.0
        INFO = -1
        WRITE(*,*) 'ERROR, INCONSISTENCY WITH THE DIMENSIONS OF THE MATRICES'
     END IF

  !CASE("C")
  CASE(3)

     IF(CA.EQ.RB) THEN
        C = MATMUL(CONJG(A),B)
     ELSE
        C = 0.0
        INFO = -1
        WRITE(*,*) 'ERROR, INCONSISTENCY WITH THE DIMENSIONS OF THE MATRICES'
     END IF

  !CASE("N")
  CASE(4)

     !WRITE(*,*) "N"
     !write(*,*) abs(A)**2
     IF(CA.EQ.RB) THEN
        !write(*,*) abs(A)**2
        C = MATMUL(A,B)
        !write(*,*) abs(C)**2
     ELSE
        C = 0.0
        INFO = -1
        WRITE(*,*) 'ERROR, INCONSISTENCY WITH THE DIMENSIONS OF THE MATRICES'
     END IF

  CASE default
     !               WRITE(*,*) "DEFAULT"
     IF(CA.EQ.RB) THEN
        C = MATMUL(A,B)
     ELSE
        C = 0.0
        INFO = -1
        WRITE(*,*) 'ERROR, INCONSISTENCY WITH THE DIMENSIONS OF THE MATRICES'
     END IF
  END SELECT

END SUBROUTINE MATMUL_C


c  a front end to several numerical recipes routines
c  for least square fitting - straight line, errors
c  in 0, 1, or 2 coords

c lstsq.f is copyright 2006 Benjamin Weiner and released under
c the GNU General Public License.  You may modify, you may redistribute,
c you must retain the copyright notice.  Please contact me with
c any comments and suggestions.

c See Weiner et al. 2006 (ApJ, in press, astro-ph/------)
c for a discussion of fitting lines to data with intrinsic scatter.

c 4/23/00 - modified to ignore input lines beginning with '#',
c   and to allow fitting only a given region

c 12/20/05 - allows adding the intrinsic scatter in quadrature
c    Iterate until you find the value of intrinsic scatter that
c    gives chisq/N = 1.  At this value, the error bars on a and b
c    should be reliable.  If you _don't_ add intrinsic scatter,
c    the errors will be underestimates.

c Benjamin Weiner, bjw at astro.umd.edu (Astronomy Dept, University
c of Maryland; Steward Observatory as of Sept 2006)

      program lstsq

      parameter(NMAX=100000)
c      parameter(NMAX_XY=1000)
      parameter(NMAX_XY=10000)

c      real x1(NMAX),x2(NMAX),x3(NMAX)x4(NMAX)
c      real x1err(NMAX),x2err(NMAX),x3err(NMAX)
      real x(NMAX), xerr(NMAX)
      real y(NMAX), yerr(NMAX)
      real xf(NMAX), xferr(NMAX)
      real yf(NMAX), yferr(NMAX)
      real xerrbot(NMAX),xerrtop(NMAX)
      real yerrbot(NMAX),yerrtop(NMAX)
      real xpl(2),ypl(2)

      character fname*40,dline*80

      big = 1.e20

      write(*,*) "0- plain least squares, 1- errors in y"
c      write(*,'(" 2- errors in x and y : "$)')
      write(*,'(" 2- errors in x and y, ",
     +     "3- x & y errors and y scatter: "$)')
c      write(*,'(" 3- y=y(x1,x2,...) : "$)')
      read(*,*) ichoose

c      if (ichoose .eq. 3) then
c         write(*,'("number of x'es [1-4]: "
c         read (*,*) nx
c      end if

 10   write (*,'("enter file: ",$)')
      read (*,*) fname

      open (2,file=fname,status='old',err=10)
      npts = 1
 20   continue
         read (2,'(a)',end=30) dline
         if (dline(1:1) .eq. '#') go to 20
         if (ichoose .eq. 0) then
            xerr(npts) = 0.
            yerr(npts) = 0.
            read (dline,*,err=20) x(npts),y(npts)
         else if (ichoose .eq. 1) then
            xerr(npts) = 0.
            read (dline,*,err=20) x(npts),y(npts),yerr(npts)
         else if (ichoose .eq. 2 .or. ichoose .eq. 3) then
            read (dline,*,err=20) x(npts),xerr(npts),
     $           y(npts),yerr(npts)
         end if
         npts=npts+1
      go to 20

 30   npts = npts-1
      write(*,*) 'Read ', npts, ' points'
      close(2)
      if (npts .gt. NMAX) then
         write(*,*) "Currently dimensioned for only max ",NMAX," points"
      end if
      if (ichoose .ge. 2 .and. npts .gt. NMAX_XY) then
       write(*,*)
     +   "Fitting w/both X and Y error will not work for >",NMAX_XY
       write(*,*) "points without redimensioning arrays in fitexy.f and"
       write(*,*) "other Numerical Recipes subroutines: chixy.f."
      end if

c for ichoose = 3, add the scatter in quadrature to the error
c and then continue as if we were doing ichoose=2
      if (ichoose .eq. 3) then
         write(*,'("intrinsic scatter in y-coord: ",$)')
         read (*,*) yintscatt
         yintscattsq = yintscatt**2
         do i=1,npts
            yerr(i) = sqrt(yerr(i)**2 + yintscattsq)
         end do
         ichoose = 2
      end if

c  moved plotting points to here

c this is sloppy and works because the errors are 0 if
c they are not supplied

      xmin = big
      xmax = -big
      ymin = big
      ymax = -big
      do i=1,npts
         xerrbot(i) = x(i)-xerr(i)
         xerrtop(i) = x(i)+xerr(i)
         yerrbot(i) = y(i)-yerr(i)
         yerrtop(i) = y(i)+yerr(i)
         xmin = min(xmin,xerrbot(i))
         xmax = max(xmax,xerrtop(i))
         ymin = min(ymin,yerrbot(i))
         ymax = max(ymax,yerrtop(i))
      end do

      xmargin = 0.1*(xmax-xmin)
      ymargin = 0.1*(ymax-ymin)
      wxmin = xmin-xmargin
      wxmax = xmax+xmargin
      wymin = ymin-ymargin
      wymax = ymax+ymargin

      call pgbegin (0,"?",1,1)
      call pgask(.false.)
      call pgscf(2)
      call pgsch(1.1)

      call pgenv(wxmin,wxmax,wymin,wymax,0,1)
      call pglabel ("x","y","Least squares fit")
      call pgpoint (npts,x,y,17)
      if(ichoose .eq. 1 .or. ichoose .eq. 2) then
         call pgerrb(6,npts,x,y,yerr,1.0)
         if (ichoose .eq. 2) then
            call pgerrb(5,npts,x,y,xerr,1.0)
         end if
      end if

c  select fitting window
      xfmin = wxmin
      xfmax = wxmax
      write (*,'("Enter xmin, xmax to fit [use all]: ",$)')
      read (*,'(a)') dline
      if (dline(1:5) .ne. '     ') then
         read(dline,*,err=40) xfmin,xfmax
      end if
 40   continue

      nf = 0
      do i=1,npts
         if(x(i) .gt. xfmin .and. x(i) .lt. xfmax) then
            nf = nf+1
            xf(nf) = x(i)
            yf(nf) = y(i)
            xferr(nf) = xerr(i)
            yferr(nf) = yerr(i)
         end if
      end do
      write(*,*) "Including ",nf," points"
      if(nf .lt.2) go to 666

c  do fit

      if (ichoose .eq. 0) then
c         call fit(x,y,npts,yerr,0,a,b,siga,sigb,chisq,q)
         call fit(xf,yf,nf,yferr,0,a,b,siga,sigb,chisq,q)
      else if (ichoose .eq. 1) then
c         call fit(x,y,npts,yerr,1,a,b,siga,sigb,chisq,q)
         call fit(xf,yf,nf,yferr,1,a,b,siga,sigb,chisq,q)
      else if (ichoose .eq. 2) then
c         call fitexy(x,y,npts,xerr,yerr,a,b,siga,sigb,chisq,q)
c         call fitexy_big(xf,yf,nf,xferr,yferr,a,b,siga,sigb,chisq,q)
         call big_fitexy(xf,yf,nf,xferr,yferr,a,b,siga,sigb,chisq,q)
      end if

c  plot fit

      xpl(1) = wxmin
      ypl(1) = a + b*wxmin
      xpl(2) = wxmax
      ypl(2) = a + b*wxmax

      call pgline(2,xpl,ypl)

      write(*,*) 'y = a + bx'
      write(*,*) 'a = ',a,' +/- ',siga
      write(*,*) 'b = ',b,' +/- ',sigb
      write(*,*) 'chisq = ',chisq,' prob. = ',q

      sumsqerr = 0.0
c      do i=1,npts
      do i=1,nf
         sumsqerr = sumsqerr + (y(i)-a-b*x(i))**2
      end do
c      write (*,*) 'rms error = ',sqrt(sumsqerr/npts)
      write (*,*) 'rms error = ',sqrt(sumsqerr/nf)

c  write data and fit to file

      open(3,file='lstsq.out',status='unknown')
      if (ichoose .eq. 0) then
         write (3,*) 'xdata       ydata       yfit'
         do i=1,npts
            write(3,*) x(i),y(i),a + b*x(i)
         end do
      else if (ichoose .eq. 1) then
         write (3,*) 'xdata       ydata        yerror       yfit'
         do i=1,npts
            write(3,*) x(i),y(i),yerr(i),a + b*x(i)
         end do
      else if (ichoose .eq. 2) then
         write (3,*)
     $        'xdata       xerror       ydata       yerror   yfit'
         do i=1,npts
            write(3,*) x(i),xerr(i),y(i),yerr(i),a + b*x(i)
         end do
      end if
      close(3)

 666  continue
      call pgend()

      end


program example
  !
  ! First, "import" all the module
  !
  use interpreter

  implicit none

  !
  ! Functions are interpreted and evaulated separately for performance.
  !
  ! The first part is to interpret the function into byte code and then
  ! evaluate the byte code for specific values of variables
  !

  character(len=1000) :: function, variables, error
  real(8), dimension(5) :: values
  real(8) :: result
  integer :: funcnum, x, y

  !
  ! define a function as a string.  This can obviously be read from
  ! an input file or from the command line if necessary
  !
  function="a*x+b+c*sin(y)"

  !
  ! define the variable names
  !
  variables="a b c x y"

  !
  ! parse the function into byte code and get back a function number
  !
  ! You can parse multiple functions and store the reference for later use
  !
  call s_createfn(function, variables, funcnum, error)

  !
  ! We can check the error if we want, in this case we are printing it off
  !
  write(*,*) trim(error)

  !
  ! Now we can evaulate the function for some set of vaules
  !

  !
  ! define the variable values
  !
  values=(/ 10, 20, 30, 40, 50 /)

  !
  ! Evaulate
  !
  call s_evaluatefn(funcnum, values, result, error)

  !
  ! Again, check the error
  !
  ! The error string is optional... leave it out of the call if you want
  !
  write(*,*) trim(error)

  !
  ! Now display the result of the function
  !
  write(*,*) "Evaulating ", trim(function), " for variables ", trim(variables), " with values ", values
  write(*,*) "results in ", result

  !
  ! If you need to, you can actually evaulate the same function for lots of different values...
  !

  do x=1,10
     do y=20,30
        values(1)=x
        values(2)=y
        call s_evaluatefn(funcnum, values, result, error)
        write(*,*) trim(error), result
     end do
  end do

  !
  ! once we are finished with the function, destroy it and clean up
  !
  call s_destroyfn(funcnum)
end program example


!*robodoc*m* CGPACK/cgca_m2glm
!  NAME
!    cgca_m2glm
!  SYNOPSIS

!$Id: cgca_m2glm.f90 379 2017-03-22 09:57:10Z mexas $

module cgca_m2glm

!  DESCRIPTION
!    Module dealing with Global to Local Mapping (glm) and vice versa
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  CONTAINS
!    cgca_gl, cgca_lg, cgca_ico
!  USES
!    cgca_m1co
!  USED BY
!    cgca_m3nucl
!  SOURCE

use cgca_m1co
implicit none

private
public :: cgca_gl, cgca_lg, cgca_ico, cgca_ico2

contains

!*roboend*

!*robodoc*s* cgca_m2glm/cgca_gl
!  NAME
!    cgca_gl
!  SYNOPSIS

subroutine cgca_gl(super,coarray,imgpos,local)

!  INPUTS

integer(kind=idef),intent(in) :: super(3)
integer(kind=iarr),allocatable,intent(inout) :: coarray(:,:,:,:)[:,:,:]

! OUTPUT

integer(kind=idef),intent(out) :: imgpos(3),local(3)

! DESCRIPTION
!   This routine converts a cell coordinate from a global, super, array
!   to the image coordinates in the coarray grid and the local cell
!   coordinates in this image :
!   - super(3) are cell coordinates in a super array
!   - coarray is the model
!   - imgpos(3) is the image position in the grid
!   - local(3) are cell coordinates in that image's array
! NOTES
!   The global coordinates must start from 1!
!
!   Any image can call this routine
! USES
! USED BY
! SOURCE

integer :: &
 lbr(4)   ,& ! lower bounds of the "real" coarray, lbv+1
 ubr(4)   ,& ! upper bounds of the "real" coarray, ubv-1
 szr(3)   ,& ! size or the "real" coarray, ubr-lbr+1
 lcob(3)  ,& ! lower cobounds of the coarray
 ucob(3)  ,& ! upper cobounds of the coarray
 usup(3)  ,& ! upper bound of the super array, szr*(ucob-lcob+1)
 thisimage

thisimage = this_image()

! check for allocated

if (.not. allocated(coarray)) then
 write (*,'(a,i0)') "ERROR: cgca_gl: image", thisimage
 write (*,'(a)') "ERROR: cgca_gl: coarray is not allocated"
 error stop
end if

lbr=lbound(coarray)+1
ubr=ubound(coarray)-1

! the 4th dimension is to do with the number of cell state
! types. This is not relevant here.
szr=ubr(1:3)-lbr(1:3)+1

lcob=lcobound(coarray)
ucob=ucobound(coarray)
usup=szr*(ucob-lcob+1)

! check for bounds

if (any(super .gt. usup) .or. any(super .lt. 1)) then
 write (*,'(a,i0)') "ERROR: cgca_gl: image", thisimage
 write (*,'(a)') "ERROR: cgca_gl: one or more super array&
                  & coordinate(s) are ouside the bounds"
 write (*,'(a,3(i0,tr1))') "ERROR: cgca_gl: super array coord: ",super
 write (*,'(a)') "ERROR: cgca_gl: lower bound must be 1"
 write (*,'(a,3(i0,tr1))') "ERROR: cgca_gl: upper bounds: ", usup
 error stop
end if

! actual calculation

imgpos = lcob + (super-1)/szr
local = lbr(1:3) + super-szr*(imgpos-lcob) - 1

! checks after

if (any(imgpos .gt. ucob) .or. any(imgpos .lt. lcob)) then
 write (*,'(a,i0)') "ERROR: cgca_gl: image", thisimage
 write (*,'(a)') "ERROR: cgca_lg: one or more image positions&
                  & are ouside the bounds"
 write (*,'(a,3(i0,tr1))') &
  "ERROR: cgca_gl: image positions: ",imgpos
 write (*,'(a,3(i0,tr1))') &
  "ERROR: cgca_gl: lower image grid bounds: ", lcob
 write (*,'(a,3(i0,tr1))') &
  "ERROR: cgca_gl: upper image grid bounds: ", ucob
 error stop
end if

if (any(local .gt. ubr(1:3)) .or. any(local .lt. lbr(1:3))) then
 write (*,'(a,i0)') "ERROR: cgca_gl: image", thisimage
 write (*,'(a)') "ERROR: cgca_lg: one or more local coordinates &
                  & are ouside the bounds"
 write (*,'(a,3(i0,tr1))') "ERROR: cgca_gl: local coordinates: ",local
 write (*,'(a,3(i0,tr1))') "ERROR: cgca_gl: lower bounds: ", lbr
 write (*,'(a,3(i0,tr1))') "ERROR: cgca_gl: upper bounds: ", ubr
 error stop
end if

end subroutine cgca_gl

!*roboend*

!*robodoc*s* cgca_m2glm/cgca_lg
!  NAME
!    cgca_lg
!  SYNOPSIS

subroutine cgca_lg(imgpos,local,coarray,super)

!  INPUTS

integer(kind=idef),intent(in) :: imgpos(3),local(3)
integer(kind=iarr),allocatable,intent(inout) :: coarray(:,:,:,:)[:,:,:]

! OUTPUT

integer(kind=idef),intent(out) :: super(3)

! DESCRIPTION
!  This routine converts the image coordinates in the grid and the local
!  cell coordinates in this image into the global cell coordinates in
!  the super array:
!   - imgpos(3) is the image position in the grid
!   - local(3) are cell coordinates in that image's array
!   - coarray is the model
!   - super(3) are cell coordinates in a super array
! NOTES
!   The global, super, coordinates must start from 1!
!
!   Any image can call this routine
! USES
! USED BY
!   cgca_gbf1f
! SOURCE

integer :: &
 lbr(4)   ,& ! lower bounds of the "real" coarray, lbv+1
 ubr(4)   ,& ! upper bounds of the "real" coarray, ubv-1
 szr(3)   ,& ! size or the "real" coarray, ubr-lbr+1
 lcob(3)  ,& ! lower cobounds of the coarray
 ucob(3)  ,& ! upper cobounds of the coarray
 usup(3)  ,& ! upper bound of the super array, szr*(ucob-lcob+1)
 thisimage

thisimage = this_image()

! check for allocated

if (.not. allocated(coarray)) then
 write (*,'(a,i0)') "ERROR: cgca_lg: image", thisimage
 write (*,'(a)') "ERROR: cgca_lg: coarray is not allocated"
 error stop
end if

lbr=lbound(coarray)+1
ubr=ubound(coarray)-1

! the 4th dimension is to do with the number of cell state
! types. This is not relevant here.
szr=ubr(1:3)-lbr(1:3)+1

lcob=lcobound(coarray)
ucob=ucobound(coarray)
usup=szr*(ucob-lcob+1)

! check for bounds

if (any(imgpos .gt. ucob) .or. any(imgpos .lt. lcob)) then
 write (*,'(a,i0)') "ERROR: cgca_lg: image", thisimage
 write (*,'(a)') "ERROR: cgca_lg: one or more image positions&
                  & are ouside the bounds"
 write (*,'(a,3(i0,tr1))') "ERROR: cgca_lg: image positions: ",imgpos
 write (*,'(a,3(i0,tr1))') &
  "ERROR: cgca_lg: lower image grid bounds: ", lcob
 write (*,'(a,3(i0,tr1))') &
  "ERROR: cgca_lg: upper image grid bounds: ", ucob
 error stop
end if

if (any(local .gt. ubr(1:3)) .or. any(local .lt. lbr(1:3))) then
 write (*,'(a,i0)') "ERROR: cgca_lg: image", thisimage
 write (*,'(a)') "ERROR: cgca_lg: one or more local coordinates&
                  & are ouside the bounds"
 write (*,'(a,3(i0,tr1))') &
  "ERROR: cgca_lg: local coordinates: ", local
 write (*,'(a,3(i0,tr1))') &
  "ERROR: cgca_lg: lower bounds: ", lbr
 write (*,'(a,3(i0,tr1))') &
  "ERROR: cgca_lg: upper bounds: ", ubr
 error stop
end if

! actual calculation

super = szr*(imgpos-lcob) + local-lbr(1:3)+1

! check for bounds

if (any(super .gt. usup) .or. any(super .lt. 1)) then
 write (*,'(a,i0)') "ERROR: cgca_lg: image", thisimage
 write (*,'(a)') "ERROR: cgca_lg: one or more super array &
                  & coordinates are ouside the bounds"
 write (*,'(a,3(i0,tr1))') &
  "ERROR: cgca_lg: super array coord: ",super
 write (*,'(a)') "ERROR: cgca_lg: lower bound must be 1"
 write (*,'(a,3(i0,tr1))') "ERROR: cgca_lg: upper bounds: ", usup
 error stop
end if

end subroutine cgca_lg

!*roboend*

!*robodoc*s* cgca_m2glm/cgca_ico
!  NAME
!    cgca_ico
!  SYNOPSIS

subroutine cgca_ico( ind, cosub, flag )

!  INPUTS

integer( kind=idef ), intent(in) :: ind

!  OUTPUT

integer( kind=idef ), intent(out) :: cosub( cgca_scodim ), flag

!  DESCRIPTION
!    This routine converts image index of coarray into its set
!    of cosubscripts.
!  NOTES
!    This is a serial routine, just computation, no inter-image
!    communication is involved.
!    Any and all images can call this routine.
!    flag is set to 0 on normal exit. flag is 1 if the coarray index
!    .lt. 0.
!  SOURCE

integer( kind=idef ) :: codim( cgca_scodim ), step, step2, rem, rem2

! Set as default
flag = 0

! Sanity check
if ( ind .le. 0 ) then

  ! Set the flag and return immediately.
  flag = 1
  return
end if

! codimensions
codim = cgca_sucob - cgca_slcob + 1

! along 1
step = mod( ind, codim(1) )
if ( step .eq. 0 ) step = codim(1)
cosub(1) = cgca_slcob(1) + step - 1

! along 2
! number of full layers
step = ind / ( codim(1) * codim(2) )

! number of images in the last unfilled layer
rem = mod( ind , codim(1) * codim(2) )

! if all layers ar filled, take step2 as codim(2)
if ( rem .eq. 0 ) then
  step2 = codim(2)
else
  ! number of full columns in the last unfilled layer
  step2 = rem / codim(1)
end if

! number of images in the last unfilled column
rem2 = mod( rem, codim(1) )

! if it's not zero, increment the step
if ( rem2 .ne. 0 ) step2 = step2 + 1

cosub(2) = cgca_slcob(2) + step2 -1

! along 3
if ( rem .ne. 0 ) step = step + 1
cosub(3) = cgca_slcob(3) + step - 1

end subroutine cgca_ico

!*roboend*

!*robodoc*s* cgca_m2glm/cgca_ico2
!  NAME
!    cgca_ico2
!  SYNOPSIS

subroutine cgca_ico2( lcob, ucob, ind, cosub )

!  INPUTS

integer( kind=idef ), intent(in) :: lcob(:), ucob(:), ind

!  OUTPUT

integer( kind=idef ), intent(out) :: cosub( size(lcob) )

!  DESCRIPTION
!    This routine converts image index of coarray into its set
!    of cosubscripts. It borrows the code from the f2008 standard,
!     http://j3-fortran.org/doc/year/10/10-007r1.pdf
!    Section C.10.1.
!  NOTES
!    This is a serial routine, just computation, no inter-image
!  SOURCE

integer :: n, i, m, ml, extent

n = size( cosub )
m = ind - 1
do i = 1, n-1
  extent = ucob(i) - lcob(i) + 1
  ml = m
  m = m / extent
  cosub( i ) = ml - m * extent + lcob(i)
end do
cosub( n ) = m + lcob( n )

end subroutine cgca_ico2

!*roboend*

end module cgca_m2glm


!>
module m_parameters

#ifdef f2003
  use , intrinsic :: iso_fortran_env , only : input_unit, output_unit, &
      error_unit
#else
#define input_unit 5
#define output_unit 6
#define error_unit 0
#endif

  implicit none

  ! file units
  integer , parameter :: STDIN = input_unit
  integer , parameter :: STDOUT = output_unit
  integer , parameter :: STDERR = error_unit

  ! pretty printing parameters
  integer , parameter :: DP_MAX = 4

  ! numeric parameters
  double precision , parameter :: NEAR_ZERO = TINY(1.0d0)
  double precision , parameter :: INFINITY = HUGE(1.0d0)
  double precision , parameter :: PI = 4.0d0*DATAN(1.0d0)
  double precision , parameter :: TOLERANCE = 1.0d-6
  double precision , parameter :: SMALL = 1.0d-4

  ! computational parameters
  integer , parameter :: MAX_ITERATIONS = 1000

end module m_parameters


! { dg-do run }
! { dg-options "-Wno-underflow" }
! Check that the chopping of bits of subnormal numbers works.
!
program chop
  real x
  x = 1.
  if (tiny(x)/2. /= tiny(x)/2. - (nearest(tiny(x),1.) - tiny(x))/2.) then
    call abort
  end if
end program chop


MODULE InitializationModule

  USE KindModule, ONLY: &
    DP, FourPi
  USE ProgramHeaderModule, ONLY: &
    ProgramName, &
    nX, nNodesX
  USE UtilitiesModule, ONLY: &
    NodeNumberX
  USE MeshModule, ONLY: &
    MeshX, &
    NodeCoordinate
  USE FluidFieldsModule, ONLY: &
    uCF, nCF, &
    uPF, nPF, iPF_D, iPF_V1, iPF_V2, iPF_V3, iPF_E, iPF_Ne, &
    uAF, iAF_P, iAF_T, iAF_S, iAF_Ye, iAF_E, iAF_Gm, iAF_Cs
  USE EquationOfStateModule, ONLY: &
    ComputeInternalEnergyDensityFromPressure, &
    ComputeAuxiliary_Fluid
  USE EulerEquationsUtilitiesModule, ONLY: &
    ComputeConserved

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: InitializeStandingAccretionShock

CONTAINS

  SUBROUTINE InitializeStandingAccretionShock &
               ( mDot, Mass, rShock, Gamma, Mach )

    REAL(DP), INTENT(in) :: mDot, Mass, rShock, Gamma, Mach

    INTEGER  :: iX1, iX2, iX3
    INTEGER  :: iNodeX1, iNodeX2, iNodeX3, iNode
    REAL(DP) :: X1, Alpha, Speed, D_prime, V1_prime, P_prime

    Alpha = 4.0_DP * Gamma / ( (Gamma + 1.0_DP) * (Gamma - 1.0_DP) ) &
              * ( (Gamma - 1.0_DP) / (Gamma + 1.0_DP) )**Gamma

    WRITE(*,*)
    WRITE(*,'(A2,A6,A)') &
      '', 'INFO: ', TRIM( ProgramName )
    WRITE(*,*)

    DO iX3 = 1, nX(3)
      DO iX2 = 1, nX(2)
        DO iX1 = 0, nX(1)+1

          DO iNodeX3 = 1, nNodesX(3)
            DO iNodeX2 = 1, nNodesX(2)
              DO iNodeX1 = 1, nNodesX(1)

                X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )

                iNode = NodeNumberX( iNodeX1, iNodeX2, iNodeX3 )

                IF( X1 <= rShock )THEN

                  CALL ComputeSettlingSpeed_Bisection &
                         ( X1, Alpha, Gamma, Mass, Speed )

                  uPF(iNode,iX1,iX2,iX3,iPF_D)  &
                    = (mDot/FourPi) * Speed**(-1.0_DP) * X1**(-2.0_DP)

                  uPF(iNode,iX1,iX2,iX3,iPF_V1) &
                    = - Speed

                  ! --- Post Shock Values from RH Conditions ---

                  V1_prime &
                    = (Gamma - 1_DP)/(Gamma + 1.0_DP) &
                        * SQRT(2.0_DP * Mass / rShock)

                  D_prime  &
                    = (mDot/FourPi) * (1.0_DP/V1_prime) &
                        * rShock**(-2.0_DP)

                  P_prime  &
                    = 2.0_DP / (Gamma + 1.0_DP) * (mDot/FourPi) &
                        * SQRT(2.0_DP * Mass) * rShock**(-2.5_DP)

                  uAF(iNode,iX1,iX2,iX3,iAF_P)  &
                    = P_prime * ( uPF(iNode,iX1,iX2,iX3,iPF_D) &
                                  / D_prime )**Gamma

                ELSE

                  Speed &
                    = SQRT &
                        (1.0_DP/(1.0_DP+2.0_DP/((Gamma-1.0_DP)*Mach**2))/X1)

                  uPF(iNode,iX1,iX2,iX3,iPF_D)  &
                    = mDot / ( FourPi * X1**2 * Speed )
                  uPF(iNode,iX1,iX2,iX3,iPF_V1) &
                    = - Speed
                  uPF(iNode,iX1,iX2,iX3,iPF_V2) &
                    = 0.0_DP
                  uPF(iNode,iX1,iX2,iX3,iPF_V3) &
                    = 0.0_DP
                  uAF(iNode,iX1,iX2,iX3,iAF_P)  &
                    = uPF(iNode,iX1,iX2,iX3,iPF_D) / Gamma &
                        * ( Speed / Mach )**2.0_DP

                END IF

              END DO
            END DO
          END DO

          CALL ComputeInternalEnergyDensityFromPressure &
                 ( uPF(:,iX1,iX2,iX3,iPF_D),  uAF(:,iX1,iX2,iX3,iAF_P), &
                   uAF(:,iX1,iX2,iX3,iAF_Ye), uPF(:,iX1,iX2,iX3,iPF_E) )

          CALL ComputeAuxiliary_Fluid &
                 ( uPF(:,iX1,iX2,iX3,iPF_D ), uPF(:,iX1,iX2,iX3,iPF_E ), &
                   uPF(:,iX1,iX2,iX3,iPF_Ne), uAF(:,iX1,iX2,iX3,iAF_P ), &
                   uAF(:,iX1,iX2,iX3,iAF_T ), uAF(:,iX1,iX2,iX3,iAF_Ye), &
                   uAF(:,iX1,iX2,iX3,iAF_S ), uAF(:,iX1,iX2,iX3,iAF_E ), &
                   uAF(:,iX1,iX2,iX3,iAF_Gm), uAF(:,iX1,iX2,iX3,iAF_Cs) )

          CALL ComputeConserved &
                 ( uPF(:,iX1,iX2,iX3,1:nPF), uCF(:,iX1,iX2,iX3,1:nCF) )

        END DO
      END DO
    END DO

  END SUBROUTINE InitializeStandingAccretionShock

  SUBROUTINE  ComputeSettlingSpeed_Bisection( r, alpha, gamma, mass, V1 )

    REAL(DP), INTENT(in) :: r, alpha, gamma, mass

    LOGICAL :: Converged
    INTEGER :: Iter
    REAL(DP) :: a, b, c, ab, F_a, F_b, F_c, F_0
    INTEGER, PARAMETER :: MaxIter = 128
    REAL(DP), PARAMETER :: Tol_ab = 1.0d-8
    REAL(DP), PARAMETER :: Tol_F = 1.0d-8

    REAL(DP), INTENT(out) :: V1

    a = 1.0d-6
    F_a = SettlingSpeedFun(a, r, alpha, gamma, mass)

    b = 1.0_DP
    F_b = SettlingSpeedFun(b, r, alpha, gamma, mass)

    F_0 = F_a
    ab = b - a

    Converged = .FALSE.
    Iter = 0

    DO WHILE ( .NOT. Converged)

      Iter = Iter + 1

      ab = 0.5_DP * ab
      c = a + ab

      F_c = SettlingSpeedFun(c, r, alpha, gamma, mass)

      IF( F_a * F_c < 0.0_DP ) THEN

        b   = c
        F_b = F_c

      ELSE

        a   = c
        F_a = F_c

      END IF

      IF( ab < Tol_ab .AND. ABS( F_a ) / F_0 < Tol_F) Converged = .TRUE.

    END DO

    V1 = a

  END SUBROUTINE ComputeSettlingSpeed_Bisection

  REAL(DP) FUNCTION SettlingSpeedFun( u, r, alpha, gamma, mass )

    REAL(DP), INTENT(in) :: u, r, alpha, gamma, mass

    SettlingSpeedFun &
      = r * u**2 &
        + alpha * r**(3.0_DP-2.0*gamma) * u**(1.0_DP-gamma) &
        - 2.0_DP * mass

    RETURN
  END FUNCTION SettlingSpeedFun

END MODULE InitializationModule