!**********************************************************************************************
		SUBROUTINE OPTIMA(NLAY,DDEP,VARI,VARM,ERROR,ERROR_E,ERROR_H,ERROR_C,SUMA,SUMA_E,SUMA_H)
!**********************************************************************************************
!*****************************************************************
!*	Written by Joaquim Perez (08/01/99)
!*	Generates the FITTING function to be optimized by POWELL
!*    or Genetics Algorithm. Function from Jorgensen 1990, and Patterson, 1984
!*	Givin a layer distribution,the position of the termocline is calculated
!*	THEN, the Root Mean Squared or the normalized RMS error of the variable
!*	can be estimated by either all of the layers, or separated
!*	into epi and hypo contributions.
!*
!*	Variable List
!*    VARM: vector with measured data
!*    VARI: vector with simulated data
!*	W_E, W_H weight functions
!*	MEAN_FIELD volumetric mean of the measured variable.
!*    MEAN_SIMUL volumetric mean of the simulated variable
!*    ERROR = measure of the error within all layers
!*    ERROR_VOL = volume-weighted error function
!*	ERROR_C = error made with Epilimnetic and Hypolimnetic contributions with weight paramters
!*	ERROR_E = error made with Epilimnetic contribution
!*	ERROR_H = error made with Hypolimnetic contribution
!*
!*****************************************************************
      USE DLMWQ_VARIABLES
      USE DLMWQ_SERVICES
		IMPLICIT NONE
      SAVE

		INTEGER*4 NLAY, NLAY_E,NLAY_H
		INTEGER*4 NLAYERS
		INTEGER*4 i,j,k
		REAL*8 MEAN_FIELD,MEAN_SIMUL
		REAL*8 VOL_TOTAL,VOL_TOTAL_H,VOL_TOTAL_E,VAR_MEDIA
     	REAL*8 ERROR,ERROR_VOL,ERROR_E,ERROR_H,ERROR_C
		REAL*8 VARI(maxns),VARM(maxns),DDEP(maxns)
		REAL*8 suma,suma_h,suma_e,suma_vol
		REAL*8 var_media_h,var_media_t
		REAL*8 mean_field_e, mean_field_h
		REAL*8 mean_simul_h, mean_simul_t
		REAL*8 lake_top,lake_bottom
		REAL*8 thermdepth
		REAL*8 xp,zc,xmass
		REAL*8 W_E,W_H
!
!     Position of the Termocline
!
		DO i =1,ndays
			IF(vector_day(i).eq.jday) THEN
				thermdepth = vector_thermdepth(i)
				GOTO 4406
			ENDIF
		ENDDO
4406  CONTINUE
!
!     Initialize variables
!
		NLAY_H = 0
		NLAY_E = 0
		W_E = 1.0
		W_H = 1.0
		SUMA = 0.0
		SUMA_H = 0.0
		SUMA_E = 0.0
		SUMA_VOL = 0.0
		ERROR = 0.0
		ERROR_E = 0.0
		ERROR_H = 0.0
		ERROR_C = 0.0
		ERROR_VOL = 0.0
		MEAN_FIELD = 0.0
      MEAN_SIMUL = 0.0
		VOL_TOTAL = 0.0
		VOL_TOTAL_H = 0.0
		VOL_TOTAL_E = 0.0
      VAR_MEDIA = 0.0
		VAR_MEDIA_H = 0.0
		VAR_MEDIA_T = 0.0
		MEAN_FIELD_E = 0.0
		MEAN_FIELD_H = 0.0
		MEAN_SIMUL_H = 0.0
		MEAN_SIMUL_T = 0.0
!
!     RMS definition
!
      IF (CALIBRATION.eq.'RMS'.OR.CALIBRATION.EQ.'rms') THEN
			IF(thermdepth.eq.-99.0) THEN    !Comment for Variables
				DO i = 1,NLAY
					MEAN_FIELD = MEAN_FIELD + VARM(I)*VOL(I)
					MEAN_SIMUL = MEAN_SIMUL + VARI(I)*VOL(I)
					VOL_TOTAL = VOL_TOTAL+VOL(I)
					SUMA = SUMA + ((VARI(I)-VARM(I)))**2
				ENDDO
			ELSE
				DO i = 1,NLAY
					SUMA = SUMA + ((VARI(I)-VARM(I)))**2
					IF (DDEP(I).LE. XMOM) THEN
						NLAY_H = NLAY_H + 1
						MEAN_FIELD_H = MEAN_FIELD_H + VARM(I)*VOL(I)
						MEAN_SIMUL_H = MEAN_SIMUL_H + VARI(I)*VOL(I)
						VOL_TOTAL_H = VOL_TOTAL_H+VOL(I)
						SUMA_H = SUMA_H + ((VARI(I)-VARM(I)))**2
					ELSE
						NLAY_E = NLAY_E + 1
						MEAN_FIELD_E = MEAN_FIELD_E + VARM(I)*VOL(I)
						MEAN_SIMUL_T = MEAN_SIMUL_T + VARI(I)*VOL(I)
						VOL_TOTAL_E = VOL_TOTAL_E+VOL(I)
						SUMA_E = SUMA_E + ((VARI(I)-VARM(I)))**2
					ENDIF
				ENDDO
			ENDIF

			IF(thermdepth.eq.-99.0) THEN
				MEAN_FIELD = MEAN_FIELD/VOL_TOTAL
 				MEAN_SIMUL = MEAN_SIMUL/VOL_TOTAL
				ERROR     = DSQRT(SUMA/NLAY)
				ERROR_E   = 0.0
				ERROR_H   = 0.0
				ERROR_C   = 0.0
				ERROR_VOL = DSQRT(SUMA_VOL/VOL_TOTAL)
			ELSE
				MEAN_FIELD =   (MEAN_FIELD_E/VOL_TOTAL_E)+ (MEAN_FIELD_H/VOL_TOTAL_H)
 				MEAN_SIMUL =   (MEAN_SIMUL_T/VOL_TOTAL_E)+ (MEAN_SIMUL_H/VOL_TOTAL_H)
				ERROR   = DSQRT(SUMA/NLAY)
				ERROR_E =  W_E*DSQRT(SUMA_E/NLAY_E)

				IF(NLAY_H.NE.0) THEN
					ERROR_H = W_H*DSQRT(SUMA_H/NLAY_H)
					ERROR_C   = W_E*DSQRT(SUMA_E/NLAY_E) + W_H*DSQRT(SUMA_H/NLAY_H)
				ELSE
					WRITE(*,*)' THERMOCLINE HAS REACHED THE BOTTOM'
					ERROR_C = W_E*DSQRT(SUMA_E/NLAY_E)
				ENDIF
			ENDIF
      ENDIF
!
!     PSI definition (RMS normalized by the mean)
!

		IF(CALIBRATION.eq.'PSI'.OR.CALIBRATION.EQ.'psi') THEN
			IF(thermdepth.eq.0) THEN    !Comment for Variables
				DO i = 1,NLAY
					MEAN_FIELD = MEAN_FIELD + VARM(I)
				ENDDO
				MEAN_FIELD = MEAN_FIELD/NLAY
				DO i = 1,NLAY
					SUMA = SUMA + ((VARI(I)-VARM(I))/MEAN_FIELD)**2
				ENDDO
				ERROR = DSQRT(SUMA/NLAY)
				ERROR_E = 0.0
				ERROR_H = 0.0
				ERROR_C = 0.0
			ELSE
				DO i = 1,NLAY
					MEAN_FIELD = MEAN_FIELD + VARM(I)
					IF (DDEP(I).LE. XMOM) THEN
						NLAY_H = NLAY_H + 1
						MEAN_FIELD_H = MEAN_FIELD_H + VARM(I)
					ELSE
						NLAY_E = NLAY_E + 1
						MEAN_FIELD_E = MEAN_FIELD_E + VARM(I)
					ENDIF
				ENDDO
				IF(NLAY_H.NE.0) THEN
					MEAN_FIELD_H = MEAN_FIELD_H / NLAY_H
				ELSE
					MEAN_FIELD_H = 0.0
				ENDIF
				MEAN_FIELD_E = MEAN_FIELD_E / NLAY_E

				DO i = 1,NLAY
					SUMA = SUMA + ((VARI(I)-VARM(I))/MEAN_FIELD)**2
					IF (DDEP(I).LE. XMOM) THEN
						SUMA_H = SUMA_H + ((VARI(I)-VARM(I))/MEAN_FIELD_H)**2
					ELSE
						SUMA_E = SUMA_E + ((VARI(I)-VARM(I))/MEAN_FIELD_E)**2
					ENDIF
				ENDDO

				ERROR = DSQRT(SUMA/NLAY)
				ERROR_E =  W_E*DSQRT(SUMA_E/NLAY_E)

				IF(NLAY_H.NE.0) THEN
					ERROR_H = W_H*DSQRT(SUMA_H/NLAY_H)
					ERROR_C   = W_E*DSQRT(SUMA_E/NLAY_E) + W_H*DSQRT(SUMA_H/NLAY_H)
				ELSE
					WRITE(*,*)' THERMOCLINE HAS REACHED THE BOTTOM'
					ERROR_C = W_E*DSQRT(SUMA_E/NLAY_E)
				ENDIF
			ENDIF
		ENDIF

		RETURN
		END SUBROUTINE OPTIMA


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

      subroutine vmec_eval_b(r, z, phi,
     .     mnmax, ns, m, n, rho0, rc, rs, zc, zs,
     .     rrc, rrs, zrc, zrs,
     .     mnmaxnyq, mnyq, nnyq, rhoh0, buc, bus, bvc, bvs,
     .     rho, theta,
     .     br, bz, bphi)

      implicit none

      real r, z, phi
      integer mnmax, ns
      integer m(mnmax), n(mnmax)
      real rho0(ns)
      real rc(mnmax, ns), rs(mnmax, ns), zc(mnmax, ns), zs(mnmax, ns),
     .     rrc(mnmax, ns), rrs(mnmax, ns),
     .     zrc(mnmax, ns), zrs(mnmax, ns)
      integer mnmaxnyq
      integer mnyq(mnmaxnyq), nnyq(mnmaxnyq)
      real rhoh0(ns - 1)
      real buc(mnmaxnyq, ns - 1), bus(mnmaxnyq, ns - 1),
     .     bvc(mnmaxnyq, ns - 1), bvs(mnmaxnyq, ns - 1)
      real rho, theta
      real br, bz, bphi

      real ph, c, s
      real rm, zm, rb, zb
      real, parameter :: rerr = 1.0e-4
      real, parameter :: zerr = 1.0e-4
      real, parameter :: rhomin = 1.0e-6
      real, parameter :: rhomax = 1.1
      real, parameter :: drhomax = 0.1
      real, parameter :: dthetamax = 0.1
      integer i, itr
      integer, parameter :: itrmax = 10
      integer ir
      real h, rci, rsi, zci, zsi, rrci, rrsi, zrci, zrsi
      real f1, f2, j11, j21, j12, j22, delta
      real dx
      real buci, busi, bvci, bvsi
      real ru, rv, zu, zv, bu, bv

!     initial guess
      rm = 0.0
      zm = 0.0
      do i = 1, mnmax
         ph = -n(i) * phi
         c = cos(ph)
         s = sin(ph)
         rm = rm + c * rc(i, 1) + s * rs(i, 1)
         zm = zm + c * zc(i, 1) + s * zs(i, 1)
      end do
      theta = atan2(z - zm, r - rm)
      rb = 0.0
      zb = 0.0
      do i = 1, mnmax
         ph = m(i) * theta - n(i) * phi
         c = cos(ph)
         s = sin(ph)
         rb = rb + c * rc(i, ns) + s * rs(i, ns)
         zb = zb + c * zc(i, ns) + s * zs(i, ns)
      end do
      rho = ((r - rm)**2 + (z - zm)**2)
     .     / ((rb - rm)**2 + (zb - zm)**2)
      rho = sqrt(rho)
      if (rho > 1.0) rho = 1.0

!     search solution
      itr = 0
      do while (.true.)
         f1 = 0.0               ! R
         f2 = 0.0               ! Z
         j11 = 0.0              ! dRdrho
         j21 = 0.0              ! dZdrho
         j12 = 0.0              ! dRdtheta (ru)
         j22 = 0.0              ! dZdtheta (zu)
         ir = int(rho**2 * (ns - 1)) + 1
         if (ir > (ns - 1)) ir = ns - 1
         h = (rho - rho0(ir)) / (rho0(ir + 1) - rho0(ir))
         do i = 1, mnmax
            rci = (1.0 - h) * rc(i, ir) + h * rc(i, ir + 1)
            rsi = (1.0 - h) * rs(i, ir) + h * rs(i, ir + 1)
            zci = (1.0 - h) * zc(i, ir) + h * zc(i, ir + 1)
            zsi = (1.0 - h) * zs(i, ir) + h * zs(i, ir + 1)
            rrci = (1.0 - h) * rrc(i, ir) + h * rrc(i, ir + 1)
            rrsi = (1.0 - h) * rrs(i, ir) + h * rrs(i, ir + 1)
            zrci = (1.0 - h) * zrc(i, ir) + h * zrc(i, ir + 1)
            zrsi = (1.0 - h) * zrs(i, ir) + h * zrs(i, ir + 1)

            ph = m(i) * theta - n(i) * phi
            c = cos(ph)
            s = sin(ph)

            f1 = f1 + c * rci + s * rsi
            f2 = f2 + c * zci + s * zsi
            j11 = j11 + c * rrci + s * rrsi
            j21 = j21 + c * zrci + s * zrsi
            j12 = j12 - m(i) * s * rci + m(i) * c * rsi
            j22 = j22 - m(i) * s * zci + m(i) * c * zsi
         end do
         f1 = f1 - r
         f2 = f2 - z

         s = (f1 / rerr)**2 + (f2 / zerr)**2
         if ((s < 1.0) .or. (rho > rhomax)) exit
         if (itr > itrmax) exit

         delta = j11 * j22 - j12 * j21
         dx = -(j22 * f1 - j12 * f2) / delta
         if (dx < -drhomax) then
            dx = -drhomax
         else if (dx > drhomax) then
            dx = drhomax
         end if
         rho = rho + dx
         if (rho < rhomin) rho = rhomin

         dx = -(-j21 * f1 + j11 * f2) / delta
         if (dx < -dthetamax) then
            dx = -dthetamax
         else if (dx > dthetamax) then
            dx = dthetamax
         end if
         theta = theta + dx

         itr = itr + 1
      end do

!     eval B
      f1 = 0.0
      f2 = 0.0
      ru = 0.0
      rv = 0.0
      zu = 0.0
      zv = 0.0
      do i = 1, mnmax
         rci = (1.0 - h) * rc(i, ir) + h * rc(i, ir + 1)
         rsi = (1.0 - h) * rs(i, ir) + h * rs(i, ir + 1)
         zci = (1.0 - h) * zc(i, ir) + h * zc(i, ir + 1)
         zsi = (1.0 - h) * zs(i, ir) + h * zs(i, ir + 1)

         ph = m(i) * theta - n(i) * phi
         c = cos(ph)
         s = sin(ph)

         f1 = f1 + c * rci + s * rsi
         f2 = f2 + c * zci + s * zsi
         ru = ru - m(i) * s * rci + m(i) * c * rsi
         rv = rv + n(i) * s * rci - n(i) * c * rsi
         zu = zu - m(i) * s * zci + m(i) * c * zsi
         zv = zv + n(i) * s * zci - n(i) * c * zsi
      end do

!     B is on half mesh
      ir = int(rho**2 * (ns - 1) + 0.5)
      if (ir < 1) then
         ir = 1
      else if (ir > (ns - 2)) then
         ir = ns - 2
      end if
      h = (rho - rhoh0(ir)) / (rhoh0(ir + 1) - rhoh0(ir))
      bu = 0.0
      bv = 0.0
      do i = 1, mnmaxnyq
         buci = (1.0 - h) * buc(i, ir) + h * buc(i, ir + 1)
         bvci = (1.0 - h) * bvc(i, ir) + h * bvc(i, ir + 1)
         busi = (1.0 - h) * bus(i, ir) + h * bus(i, ir + 1)
         bvsi = (1.0 - h) * bvs(i, ir) + h * bvs(i, ir + 1)

         ph = mnyq(i) * theta - nnyq(i) * phi
         c = cos(ph)
         s = sin(ph)

         bu = bu + c * buci + s * busi
         bv = bv + c * bvci + s * bvsi
      end do

      br = bu * ru + bv * rv
      bz = bu * zu + bv * zv
      bphi = r * bv

      return
      end

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

      subroutine vmec_read_head_695(lun, rmaxsurf, rminsurf, zmaxsurf,
     .     nfp, ns, mnmax, lasymlogical, ierflag, nbsets)

      implicit none

      integer lun
      real wb, wp, gamma, pfac, rmaxsurf, rminsurf, zmaxsurf
      integer nfp, ns, mpol, ntor, mnmax, itfsq, niter,
     .     lasymlogical, lreconlogical, ierflag
      integer imse, itse, nbsets, nobd, nextcur, nstore_seq

 100  format(6(1x,i11))
 110  format(3(1x,e23.15))

      read(lun, 110) wb, wp, gamma, pfac,
     .     rmaxsurf, rminsurf, zmaxsurf
      read(lun, 100) nfp, ns, mpol, ntor, mnmax, itfsq, niter,
     .     lasymlogical, lreconlogical, ierflag
      read(lun, 100) imse, itse, nbsets, nobd, nextcur, nstore_seq

      return
      end

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

      subroutine vmec_setup(icontxt, myid, nproc, iwout, wout,
     .     nxmx, nymx, nphimx, nnodex, nnodey, nnodephi,
     .     capr, y, phi, rwleft, rwright, ytop, ybottom, rt, b0,
     .     bxn, byn, bzn, bmod, psi, rho, thetap, nfp)

      use netcdf

      implicit none

      integer*4 istatus, ncid, mndimid, sdimid, nfpid,
     .     xmid, xnid, rmncid, zmnsid, bumncid, bvmncid
      integer*4 mnmax_r, ns_r

      integer myid, nproc, id
      integer icontxt
      integer iwout
      character*128 wout
      integer nxmx, nymx, nphimx
      integer nnodex, nnodey, nnodephi
      real capr(nxmx), y(nymx), phi(nphimx)
      real rwleft, rwright, ytop, ybottom, rt, b0
      real bxn(nxmx, nymx, nphimx),
     .     byn(nxmx, nymx, nphimx),
     .     bzn(nxmx, nymx, nphimx),
     .     bmod(nxmx, nymx, nphimx)
      real psi(nxmx, nymx, nphimx),
     .     thetap(nxmx, nymx, nphimx),
     .     rho(nxmx, nymx, nphimx)
      integer nfp

      integer :: lun = 40
      real wout_version
      real rmaxsurf, rminsurf, zmaxsurf
      integer ns, mnmax, lasymlogical, ierflag, nbsets
      real, allocatable, dimension(:) :: nbfld
      character*128 mgridfile
      integer, allocatable, dimension(:) :: xm, xn
      real, allocatable, dimension(:, :) :: rmnc, rmns, zmnc, zmns,
     .     lmnc, lmns, bmnc, gmnc, bsubumnc, bsubvmnc, bsubsmns,
     .     bsupumnc, bsupumns, bsupvmnc, bsupvmns,
     .     currvmnc,
     .     rrmnc, rrmns, zrmnc, zrmns
      real, allocatable, dimension(:) :: rho0, rhoh0

      integer i, j, k, ngrid
      real dx, dy, dphi, phimax

      real, parameter :: pi = 3.141592654

      if (iwout .eq. 0) then
         istatus = nf90_open(TRIM(wout), NF90_NOWRITE, ncid)

         istatus = nf90_inq_dimid(ncid, 'mn', mndimid)
         istatus = nf90_inq_dimid(ncid, 's', sdimid)
         istatus = nf90_inquire_dimension(ncid, mndimid, len=mnmax_r)
         istatus = nf90_inquire_dimension(ncid, sdimid, len=ns_r)
         mnmax = mnmax_r
         ns = ns_r

         istatus = nf90_inq_varid(ncid, 'nfp', nfpid)
         istatus = nf90_get_var(ncid, nfpid, nfp)
      else
         open(unit=lun, file=wout, status="old", form="formatted")

         read(lun, "(15x,f4.2)") wout_version
         if (myid .eq. 0) then
            write(6, "(' wout version = ',f4.2)") wout_version
         end if

         call vmec_read_head_695(lun, rmaxsurf, rminsurf, zmaxsurf,
     .        nfp, ns, mnmax, lasymlogical, ierflag, nbsets)
         if ((ierflag .ne. 0) .and. (ierflag .ne. 4)) then
           write(6, *) "ierflag = ", ierflag
         end if

         if (nbsets > 0) then
            allocate(nbfld(nbsets))
            read(lun, 110) (nbfld(i), i = 1, nbsets)
            deallocate(nbfld)
         end if

         read(lun, "(a)") mgridfile
      end if

      allocate(xm(mnmax))
      allocate(xn(mnmax))
      allocate(rmnc(mnmax, ns))
      allocate(rmns(mnmax, ns))
      allocate(zmnc(mnmax, ns))
      allocate(zmns(mnmax, ns))
      allocate(lmnc(mnmax, ns - 1))
      allocate(lmns(mnmax, ns - 1))
      allocate(bmnc(mnmax, ns - 1))
      allocate(gmnc(mnmax, ns - 1))
      allocate(bsubumnc(mnmax, ns - 1))
      allocate(bsubvmnc(mnmax, ns - 1))
      allocate(bsubsmns(mnmax, ns - 1))
      allocate(bsupumnc(mnmax, ns - 1))
      allocate(bsupumns(mnmax, ns - 1))
      allocate(bsupvmnc(mnmax, ns - 1))
      allocate(bsupvmns(mnmax, ns - 1))
      allocate(currvmnc(mnmax, ns - 1))

      if (iwout .eq. 0) then
         istatus = nf90_inq_varid(ncid, 'xm', xmid)
         istatus = nf90_get_var(ncid, xmid, xm)
         istatus = nf90_inq_varid(ncid, 'xn', xnid)
         istatus = nf90_get_var(ncid, xnid, xn)
         istatus = nf90_inq_varid(ncid, 'rmnc', rmncid)
         istatus = nf90_get_var(ncid, rmncid, rmnc)
         istatus = nf90_inq_varid(ncid, 'zmns', zmnsid)
         istatus = nf90_get_var(ncid, zmnsid, zmns)
         istatus = nf90_inq_varid(ncid, 'bsupumnc', bumncid)
         istatus = nf90_get_var(ncid, bumncid, bsupumnc)
         istatus = nf90_inq_varid(ncid, 'bsupvmnc', bvmncid)
         istatus = nf90_get_var(ncid, bvmncid, bsupvmnc)

         istatus = nf90_close(ncid)
      else
 100     format(6(1x,i11))
 110     format(3(1x,e23.15))

         bsupumns = 0.0
         bsupvmns = 0.0

         if (lasymlogical .gt. 0) then
            do i = 1, mnmax
               read(lun, 100) xm(i), xn(i)
               read(lun, 110) rmnc(i, 1), zmns(i, 1),
     .             lmns(i, 1), bmnc(i, 1), gmnc(i, 1),
     .             bsubumnc(i, 1), bsubvmnc(i, 1), bsubsmns(i, 1),
     .             bsupumnc(i, 1), bsupvmnc(i, 1), currvmnc(i, 1),
     .             rmns(i, 1), zmnc(i, 1), lmnc(i, 1)
            end do
            do j = 1, ns - 1
               do i = 1, mnmax
                  read(lun, 110) rmnc(i, j + 1), zmns(i, j + 1),
     .                lmns(i, j), bmnc(i, j), gmnc(i, j),
     .                bsubumnc(i, j), bsubvmnc(i, j), bsubsmns(i, j),
     .                bsupumnc(i, j), bsupvmnc(i, j), currvmnc(i, j),
     .                rmns(i, j + 1), zmnc(i, j + 1), lmnc(i, j)
               end do
            end do
         else
            rmns = 0.0
            zmnc = 0.0
            lmnc = 0.0

            do i = 1, mnmax
               read(lun, 100) xm(i), xn(i)
               read(lun, 110) rmnc(i, 1), zmns(i, 1),
     .             lmns(i, 1), bmnc(i, 1), gmnc(i, 1),
     .             bsubumnc(i, 1), bsubvmnc(i, 1), bsubsmns(i, 1),
     .             bsupumnc(i, 1), bsupvmnc(i, 1), currvmnc(i, 1)
            end do
            do j = 1, ns - 1
               do i = 1, mnmax
                  read(lun, 110) rmnc(i, j + 1), zmns(i, j + 1),
     .                lmns(i, j), bmnc(i, j), gmnc(i, j),
     .                bsubumnc(i, j), bsubvmnc(i, j), bsubsmns(i, j),
     .                bsupumnc(i, j), bsupvmnc(i, j), currvmnc(i, j)
               end do
            end do
         end if

         close(lun)
      end if

      allocate(rho0(ns))
      allocate(rhoh0(ns - 1))
      allocate(rrmnc(mnmax, ns))
      allocate(rrmns(mnmax, ns))
      allocate(zrmnc(mnmax, ns))
      allocate(zrmns(mnmax, ns))

!     mesh
      dx = (rmaxsurf - rminsurf) * 0.1
      if (rwleft .eq. 0.0) rwleft = rminsurf - dx
      if (rwright .eq. 0.0) rwright = rmaxsurf + dx
      dx = zmaxsurf * 0.2
      if (ybottom .eq. 0.0) ybottom = -zmaxsurf - dx
      if (ytop .eq. 0.0) ytop = zmaxsurf + dx

      dx = (rwright - rwleft) / nnodex
      do i = 1, nnodex
         capr(i) = (i-1) * dx  + dx / 2.0 + rwleft
      end do
      dy = (ytop - ybottom) / nnodey
      do j = 1, nnodey
         y(j) = (j-1) * dy  + dy / 2.0 + ybottom
      end do
      phimax = 2.0 * pi / nfp
      dphi = phimax / nnodephi
      do k = 1, nnodephi
         phi(k) = (k-1) * dphi - phimax / 2.0
      end do

      do i = 1, ns
         rho0(i) = sqrt(real(i - 1) / (ns - 1))
      end do
      do i = 1, ns - 1
         rhoh0(i) = sqrt((i - 0.5) / (ns - 1))
      end do

!     rho derivatives
      do i = 2, ns - 1
         rrmnc(:, i) = (rmnc(:, i + 1) - rmnc(:, i - 1))
     .        / (rho0(i + 1) - rho0(i - 1))
         rrmns(:, i) = (rmns(:, i + 1) - rmns(:, i - 1))
     .        / (rho0(i + 1) - rho0(i - 1))
         zrmnc(:, i) = (zmnc(:, i + 1) - zmnc(:, i - 1))
     .        / (rho0(i + 1) - rho0(i - 1))
         zrmns(:, i) = (zmns(:, i + 1) - zmns(:, i - 1))
     .        / (rho0(i + 1) - rho0(i - 1))
      end do
      rrmnc(:, 1) = (rmnc(:, 2) - rmnc(:, 1)) / (rho0(2) - rho0(1))
      rrmns(:, 1) = (rmns(:, 2) - rmns(:, 1)) / (rho0(2) - rho0(1))
      zrmnc(:, 1) = (zmnc(:, 2) - zmnc(:, 1)) / (rho0(2) - rho0(1))
      zrmns(:, 1) = (zmns(:, 2) - zmns(:, 1)) / (rho0(2) - rho0(1))
      rrmnc(:, ns) = (rmnc(:, ns) - rmnc(:, ns - 1))
     .     / (rho0(ns) - rho0(ns - 1))
      rrmns(:, ns) = (rmns(:, ns) - rmns(:, ns - 1))
     .     / (rho0(ns) - rho0(ns - 1))
      zrmnc(:, ns) = (zmnc(:, ns) - zmnc(:, ns - 1))
     .     / (rho0(ns) - rho0(ns - 1))
      zrmns(:, ns) = (zmns(:, ns) - zmns(:, ns - 1))
     .     / (rho0(ns) - rho0(ns - 1))

!     invert (rho, theta) & evaluate B
      rho = 0.0
      psi = 0.0                 ! =rho^2
      thetap = 0.0
      bmod = 0.0
      bxn = 0.0
      byn = 0.0
      bzn = 0.0
      do k = 1, nnodephi
         do i = 1, nnodex
            do j = 1, nnodey
               ngrid = (k - 1) * nnodex * nnodey
     .               + (j - 1) * nnodex
     .               +  i
               id = mod(ngrid, nproc)
               if (id .eq. myid) then
                  call vmec_eval_b(capr(i), y(j), phi(k),
     .                mnmax, ns, xm, xn, rho0, rmnc, rmns, zmnc, zmns,
     .                rrmnc, rrmns, zrmnc, zrmns,
     .                mnmax, xm, xn, rhoh0, bsupumnc, bsupumns,
     .                bsupvmnc, bsupvmns,
     .                rho(i, j, k), thetap(i, j, k),
     .                bxn(i, j, k), byn(i, j, k), bzn(i, j, k))

                  rho(i, j, k) = rho(i, j, k)
                  psi(i, j, k) = rho(i, j, k)**2
                  bmod(i, j, k) = bxn(i, j, k)**2 + byn(i, j, k)**2
     .                 + bzn(i, j, k)**2
                  bmod(i, j, k) = sqrt(bmod(i, j, k))
                  if (bmod(i, j, k) .gt. 0.0) then
                     bxn(i, j, k) = bxn(i, j, k) / bmod(i, j, k)
                     byn(i, j, k) = byn(i, j, k) / bmod(i, j, k)
                     bzn(i, j, k) = bzn(i, j, k) / bmod(i, j, k)
                  end if
               end if
            end do
         end do
      end do

      deallocate(xm)
      deallocate(xn)
      deallocate(rmnc)
      deallocate(rmns)
      deallocate(zmnc)
      deallocate(zmns)
      deallocate(lmnc)
      deallocate(lmns)
      deallocate(bmnc)
      deallocate(gmnc)
      deallocate(bsubumnc)
      deallocate(bsubvmnc)
      deallocate(bsubsmns)
      deallocate(bsupumnc)
      deallocate(bsupumns)
      deallocate(bsupvmnc)
      deallocate(bsupvmns)
      deallocate(currvmnc)

      deallocate(rho0)
      deallocate(rhoh0)
      deallocate(rrmnc)
      deallocate(rrmns)
      deallocate(zrmnc)
      deallocate(zrmns)

      call blacs_barrier(icontxt, 'All')

      call dgsum2d(icontxt, 'All', ' ', nxmx * nymx, nnodephi,
     .     rho, nxmx * nymx, -1, -1)
      call dgsum2d(icontxt, 'All', ' ', nxmx * nymx, nnodephi,
     .     psi, nxmx * nymx, -1, -1)
      call dgsum2d(icontxt, 'All', ' ', nxmx * nymx, nnodephi,
     .     thetap, nxmx * nymx, -1, -1)
      call dgsum2d(icontxt, 'All', ' ', nxmx * nymx, nnodephi,
     .     bmod, nxmx * nymx, -1, -1)
      call dgsum2d(icontxt, 'All', ' ', nxmx * nymx, nnodephi,
     .     bxn, nxmx * nymx, -1, -1)
      call dgsum2d(icontxt, 'All', ' ', nxmx * nymx, nnodephi,
     .     byn, nxmx * nymx, -1, -1)
      call dgsum2d(icontxt, 'All', ' ', nxmx * nymx, nnodephi,
     .     bzn, nxmx * nymx, -1, -1)

      rt = (rwleft + rwright) * 0.5
      b0 = bmod(nnodex / 2, nnodey / 2, nnodephi / 2)

      call blacs_barrier(icontxt, 'All')

!     write transform.out
      if (myid .eq. 0) then
 310     format(1p6e12.4)
 309     format(10i10)

         open(unit=40,file='transform.out',status='unknown',
     .      form='formatted')

         write(40, 309) nnodex, nnodey, nnodephi
         write(40, 310) rt, b0
         write(40, 310) (((bxn(i,j,k), i = 1, nnodex), j = 1, nnodey),
     .                    k = 1, nnodephi)
         write(40, 310) (((byn(i,j,k), i = 1, nnodex), j = 1, nnodey),
     .                    k = 1, nnodephi)
         write(40, 310) (((bzn(i,j,k), i = 1, nnodex), j = 1, nnodey),
     .                    k = 1, nnodephi)
         write(40, 310) (((bmod(i,j,k), i = 1, nnodex), j = 1, nnodey),
     .                    k = 1, nnodephi)
         write(40, 310) (((psi(i,j,k), i = 1, nnodex), j = 1, nnodey),
     .                    k = 1, nnodephi)
         write(40, 310) (((rho(i,j,k), i = 1, nnodex), j = 1, nnodey),
     .                    k = 1, nnodephi)
         write(40, 310) (((thetap(i,j,k), i = 1, nnodex), j=1, nnodey),
     .                    k = 1, nnodephi)
         write(40, 309) nfp

         close(40)
      end if

      return
      end


*     TG01DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LMAX, NMAX, PMAX
      PARAMETER        ( LMAX = 20, NMAX = 20, PMAX = 20)
      INTEGER          LDA, LDC, LDE, LDZ
      PARAMETER        ( LDA = LMAX, LDC = PMAX,
     $                   LDE = LMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MIN(LMAX,NMAX)+MAX(LMAX,NMAX,PMAX) )
*     .. Local Scalars ..
      CHARACTER*1      COMPZ
      INTEGER          I, INFO, J, L, N, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), E(LDE,NMAX), Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         TG01DD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, N, P
      COMPZ = 'I'
      IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) L
      ELSE
         IF( N.LT.0 .OR. N.GT.NMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) N
         ELSE
            READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,L )
            READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,L )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find the transformed descriptor system pair
*              (A-lambda E,B).
               CALL TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC,
     $                      Z, LDZ, DWORK, LDWORK, INFO )
*
               IF( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 10 I = 1, L
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10             CONTINUE
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, L
                     WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99994 )
                  DO 30 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,N )
   30             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, N
                     WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   40             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TG01DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TG01DD = ',I2)
99997 FORMAT (/' The transformed state dynamics matrix A*Z is ')
99996 FORMAT (/' The transformed descriptor matrix E*Z is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' The transformed input/state matrix C*Z is ')
99993 FORMAT (/' The right transformation matrix Z is ')
99992 FORMAT (/' L is out of range.',/' L = ',I5)
99991 FORMAT (/' N is out of range.',/' N = ',I5)
99990 FORMAT (/' P is out of range.',/' P = ',I5)
      END


      DOUBLE PRECISION FUNCTION rlog1(x)
C-----------------------------------------------------------------------
C             EVALUATION OF THE FUNCTION X - LN(1 + X)
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a,b,h,p0,p1,p2,q1,q2,r,t,w,w1
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dble,dlog
C     ..
C     .. Data statements ..
C------------------------
      DATA a/.566749439387324D-01/
      DATA b/.456512608815524D-01/
      DATA p0/.333333333333333D+00/,p1/-.224696413112536D+00/,
     +     p2/.620886815375787D-02/
      DATA q1/-.127408923933623D+01/,q2/.354508718369557D+00/
C     ..
C     .. Executable Statements ..
C------------------------
      IF (x.LT.-0.39D0 .OR. x.GT.0.57D0) GO TO 40
      IF (x.LT.-0.18D0) GO TO 10
      IF (x.GT.0.18D0) GO TO 20
C
C              ARGUMENT REDUCTION
C
      h = x
      w1 = 0.0D0
      GO TO 30
C
   10 h = dble(x) + 0.3D0
      h = h/0.7D0
      w1 = a - h*0.3D0
      GO TO 30
C
   20 h = 0.75D0*dble(x) - 0.25D0
      w1 = b + h/3.0D0
C
C               SERIES EXPANSION
C
   30 r = h/ (h+2.0D0)
      t = r*r
      w = ((p2*t+p1)*t+p0)/ ((q2*t+q1)*t+1.0D0)
      rlog1 = 2.0D0*t* (1.0D0/ (1.0D0-r)-r*w) + w1
      RETURN
C
C
   40 w = (x+0.5D0) + 0.5D0
      rlog1 = x - dlog(w)
      RETURN

      END


! $Id: num_rec.f90,v 1.1 2008-07-24 17:31:45 dschanen Exp $
!   From _Numerical Recipes in Fortran 90_
!   (C) 1988-1996 Numerical Recipes Software
SUBROUTINE amoeba( p, y, f_tol, func, iter )
USE nrtype
USE nrutil, ONLY : assert_eq, imaxloc, iminloc, nrerror, swap

IMPLICIT NONE

INTEGER(I4B), INTENT(OUT) :: iter
REAL(SP), INTENT(IN)      :: f_tol
REAL(SP), DIMENSION(:), INTENT(INOUT)   :: y
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p
INTERFACE
  FUNCTION func(x)
  USE nrtype
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: x
  REAL(SP) :: func
  END FUNCTION func
END INTERFACE

INTEGER(I4B), PARAMETER :: ITMAX = 5000
REAL(SP), PARAMETER     :: TINY  = 1.0e-10
INTEGER(I4B)            :: ihi, ndim

REAL(SP), DIMENSION(size( p, 2 )) :: psum

call amoeba_private

RETURN

CONTAINS
!BL
SUBROUTINE amoeba_private
IMPLICIT NONE

INTEGER(I4B) :: i,ilo,inhi
REAL(SP)     :: r_tol,ysave,ytry,ytmp

ndim    = assert_eq( size(p,2), size(p,1)-1, size(y)-1, 'amoeba' )
iter    = 0
psum(:) = sum( p(:,:), dim = 1 )

do
  ilo    = iminloc( y(:) )
  ihi    = imaxloc( y(:) )
  ytmp   = y(ihi)
  y(ihi) = y(ilo)
  inhi   = imaxloc( y(:) )
  y(ihi) = ytmp
  r_tol   = 2.0_sp * abs( y(ihi) - y(ilo) ) /       &
           ( abs( y(ihi) ) + abs( y(ilo) ) + TINY )
  if (r_tol < f_tol) then
    call swap( y(1), y(ilo) )
    call swap( p(1,:), p(ilo,:) )
    RETURN
  end if
!  if (iter >= ITMAX) call nrerror('ITMAX exceeded in amoeba')
! Make amoeba return the non-optimal result. -dschanen 6/14/2005
  if (iter >= ITMAX) then
    print *, 'ITMAX exceeded in amoeba'
    RETURN
  endif
  ytry = amotry( -1.0_sp )
  iter = iter + 1
  if (ytry <= y(ilo)) then
    ytry = amotry( 2.0_sp )
    iter = iter + 1
  else if (ytry >= y(inhi)) then
    ysave = y(ihi)
    ytry  = amotry( 0.5_sp )
    iter  = iter + 1
    if (ytry >= ysave) then
      p(:,:) = 0.5_sp * (p(:, :) + spread( p(ilo, :), 1, size(p, 1) ))
      do i=1, ndim+1
        if (i /= ilo) y(i) = func( p(i, :) )
      end do
      iter    = iter + ndim
      psum(:) = sum( p(:, :), dim=1 )
    end if
  end if
end do

RETURN
END SUBROUTINE amoeba_private
!BL
FUNCTION amotry(fac)
IMPLICIT NONE

REAL(SP), INTENT(IN) :: fac
REAL(SP)             :: amotry
REAL(SP)             :: fac1, fac2, ytry

REAL(SP), DIMENSION(size(p,2)) :: ptry

fac1    = (1.0_sp - fac) / ndim
fac2    = fac1 - fac
ptry(:) = psum(:) * fac1 - p(ihi,:) * fac2
ytry    = func( ptry )

if (ytry < y(ihi)) then
  y(ihi)   = ytry
  psum(:)  = psum(:) - p(ihi,:) + ptry(:)
  p(ihi,:) = ptry(:)
end if

amotry = ytry

RETURN
END FUNCTION amotry

END SUBROUTINE amoeba


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_UPDT_VZWW

    USE MR_KINDS

    USE MR_DEF_RANKS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_FIELD_VARS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_UPDT_VZWW

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_UPDT_VZWW

    USE MR_MOD_FUNC_VZWW

    USE MR_MOD_INTERP_XY
    USE MR_MOD_INTERP_Z

    IMPLICIT NONE

    INTEGER(IJID_KIND) :: I , J
    INTEGER(KKID_KIND) :: K

    DO K = 1 , NK

      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          VZWW( I , J , K ) = MR_FUNC_VZWW( V0 , KI( I , J , K ) , DI( I , J , K ) )
        END DO
      END DO

      CALL MR_INTERP_XY_SS_U( NI , NJ , VZWW(:,:, K ) , VXYU(:,:, K ) )
      CALL MR_INTERP_XY_SS_V( NI , NJ , VZWW(:,:, K ) , VXYV(:,:, K ) )

    END DO

    CALL MR_INTERP_Z_SS_W( NI , NJ , NK , VZWW , VZW )

  END SUBROUTINE MR_UPDT_VZWW

  END MODULE MR_MOD_UPDT_VZWW


      program cstexp
c     To check that max0
      parameter (i=1, j=2*i, k = max0(i,j))
      real a(i), b(j), c(k)

      print *, a(i)

      l = k

      print *,l

      end


      PROGRAM xspear
C     driver for routine spear
      INTEGER NDAT,NMON
      PARAMETER(NDAT=20,NMON=12)
      INTEGER i,j
      REAL d,probd,probrs,rs,zd
      REAL data1(NDAT),data2(NDAT),rays(NDAT,NMON)
      REAL wksp1(NDAT),wksp2(NDAT),ave(NDAT),zlat(NDAT)
      CHARACTER city(NDAT)*15,mon(NMON)*4,text*64
      open(7,file='TABLE2.DAT',status='OLD')
      read(7,*)
      read(7,'(a)') text
      read(7,'(15x,12a4/)') (mon(i),i=1,12)
      do 11 i=1,NDAT
        read(7,'(a15,12f4.0,f6.0,f6.1)')
     *       city(i),(rays(i,j),j=1,12),ave(i),zlat(i)
11    continue
      close(7)
      write(*,*) text
      write(*,'(1x,15x,12a4)') (mon(i),i=1,12)
      do 12 i=1,NDAT
        write(*,'(1x,a,12i4,i6,f6.1)') city(i),
     *       (nint(rays(i,j)),j=1,12)
12    continue
C     check temperature correlations between different months
      write(*,'(/1x,a)')
     *     'Are sunny summer places also sunny winter places?'
      write(*,'(1x,2a)') 'Check correlation of sampled U.S. solar ',
     *     'radiation (july with other months)'
      write(*,'(/1x,a,t16,a,t23,a,t37,a,t49,a,t63,a/)')
     *     'Month','D','St. Dev.','PROBD',
     *     'Spearman R','PROBRS'
      do 13 i=1,NDAT
        data1(i)=rays(i,1)
13    continue
      do 15 j=1,12
        do 14 i=1,NDAT
          data2(i)=rays(i,j)
14      continue
        call spear(data1,data2,NDAT,wksp1,wksp2,d,zd,probd,rs,probrs)
        write(*,'(1x,a,f13.2,2f12.6,3x,2f12.6)')
     *       mon(j),d,zd,probd,rs,probrs
15    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xspear.for


PROGRAM PERF2D
	USE NRTYPE
	USE MATLIB
	USE PARAM
	USE GROUND
	IMPLICIT NONE
	!-----------------------------------------------------------
	!Compile instructions in infratopo/PE/2DPE:
	!
	!gfortran -g -fbacktrace -Wtabs -o PERF2D PERF2D.f03 nrtype.f03 param.f03 ground.f03 matlib.f03 -llapack -lblas
	!*** nrtype, param, ground, matlib : module files ***
	!-----------------------------------------------------------
	WRITE(*,*) ""
	WRITE(*,*) "================================================"
	WRITE(*,*) "========== Parabolic Equation Package =========="
	WRITE(*,*) "================================================"
	WRITE(*,*) ""
	WRITE(*,*) "University of Bristol"
	WRITE(*,*) "Aerodynamics and Aeroacoustics Research Group"
	WRITE(*,*) ""
	WRITE(*,*) "Codor Khodr, July 2016"
	WRITE(*,*) ""
	WRITE(*,*) "================================================"
	WRITE(*,*) ""
	WRITE(*,*) "PERF2D - Performance Test Function for PE"
	WRITE(*,*) "Dimension 	: 	2D"
	WRITE(*,*) "Atmosphere	:	Homogeneous"
	WRITE(*,*) "Boundary 	:	Flat"
	WRITE(*,*) "Impedance	:	Rigid"
	WRITE(*,*) ""
	WRITE(*,*) "================================================"
	WRITE(*,*) ""
	WRITE(*,*) "propagation range = 10000 m"
	WRITE(*,*) "frequency = 10Hz , wavelength = 34.3 m"
	WRITE(*,*) "source height = 5 m"
	WRITE(*,*) "max slope of terrain = 40 degrees"
	WRITE(*,*) ""
	!-----------------------------------------------------------
	!----------------------------------------------------------
	L = 10000
	F = 10
	ZS = 5
	ABL = 0.07
	ANGLE = 40
	C0 = 343
	lmbda0 = C0/F
	K0 = 2*PI*F/C0
	Dz = lmbda0/10
	Dr = lmbda0/10
	H = 100*lmbda0
	HABL = 30*lmbda0
	N = FLOOR(H/dz)
	M = FLOOR(L/dr)
	WRITE(*,*) "================================================"
	WRITE(*,*) ""
	WRITE(*,*) "Size of the system : ", N
	WRITE(*,*) "Number of loops : ", M
	WRITE(*,*) ""
	WRITE(*,*) "================================================"
	NS = MAX(1,FLOOR(ZS/DZ))
	NABL = FLOOR(HABL/dz)
	ALPHA = IM/(2*K0*DZ**2)
	!-----------------------------------------------------------
	!-----------------------------------------------------------
	!Memory allocation
	ALLOCATE(K(N), DK2(N), ALT(N), PHI(N,M+1), T(N,N), D(N,N), M1(N,N), &
	M2(N,N), MAT(N,N), I(N,N), P(N,M), LP(N,M), LP2(N,M), LPG(M), LPG2(M), &
	TERR2(1:M), LIN(0:M+1), TERR1(1:M+1), E(N,N), TEMP(N))
	!-----------------------------------------------------------
	!Atmosphere
	!-----------------------------------------------------------
	!
	DO NZ = 1,N
		IF (NZ >= N-NABL) THEN
			K(NZ) = K0+ABL*im*(NZ-N+NABL)**2/NABL**2
		ELSE
			K(NZ) = K0
		ENDIF
		DK2(NZ) = im*(K(NZ)**2-(K0**2))/(2*K0)
		ALT(NZ) = NZ*Dz
	END DO
	TAU1 = 4/(3-2*im*K0*Dz)
	TAU2 = -1/(3-2*im*K0*Dz)
	SIGMA1 = 4/3
	SIGMA2 = -1/3
	!-----------------------------------------------------------
	!Terrain
	!-----------------------------------------------------------
	LIN(0) = 0
	THETA = ANGLE*PI/180
	H0 = SQRT(EXP(1.)/2)*L*ATAN(THETA)
	S = 3*L/10
	DO MX = 1,M+1
		XL = GHILL(H0,X0,(MX-1)*DR,S)
		XR = GHILL(H0,X0,MX*DR,S)
		TERR1(MX) = (XR-XL)/Dr
		LIN(MX) = LIN(MX-1)+(1+TERR1(MX))*Dr
	END DO
	!-----------------------------------------------------------
	!Starting field
	!-----------------------------------------------------------
	A0 = 1.3717
	A2 = -0.3701
	B = 3
	DO NZ = 1,N
		PHI(NZ,1) = SQRT(im*K0)* &
		((A0+A2*K0**2*(NZ*Dz-ZS)**2)*EXP(-K0**2*(NZ*Dz-ZS)**2/B) &
		+ (A0+A2*K0**2*(NZ*Dz+ZS)**2)*EXP(-K0**2*(NZ*Dz+ZS)**2/B))
	END DO
	!-----------------------------------------------------------
	!Matrix building
	!-----------------------------------------------------------
	!Initialization (Dense Matrices)
	!---------
	T(:,:) = 0.
	D(:,:) = 0.
	E(:,:) = 0.
	I = EYE(N)
	!---------
	DO NZ = 1,N !Out of bound elements ignored
		T(NZ,NZ-1) = T(NZ,NZ-1)+1
		T(NZ,NZ) = T(NZ,NZ)-2
		T(NZ,NZ+1) = T(NZ,NZ+1)+1
		D(NZ,NZ) = DK2(NZ)
		E(NZ,NZ) = NZ*DZ
	END DO
	T(1,1) = T(1,1)-2+SIGMA1
	T(1,2) = T(1,2)+1+SIGMA2
	T(N,N-1) = T(N,N-1)+1+TAU2
	T(N,N) = T(N,N)-2+TAU1
	!-----------------------------------------------------------
	!Forward-marching procedure
	CALL CPU_TIME(TI)
	!-----------------------------------------------------------
	DO MX = 2,M+1
		WRITE(*, *) "Step :", MX-1, "out of", M
		TERR2(MX-1) = (TERR1(MX)-TERR1(MX-1))/Dr		!Varying coefficient to be injected...
		D = D-IM*K0*TERR2(MX-1)*E				!... inside the D matrix
		WRITE(*, *) ".... D Updated"
		M1 = I+(Dr/2)*(ALPHA*T+D)+(1/(2*im*K0))*(ALPHA*T+D)	!Now the matrices M1 and M2 vary
		M2 = I-(Dr/2)*(ALPHA*T+D)+(1/(2*im*K0))*(ALPHA*T+D)	!from step to step because of D
		TEMP = MATMUL(M1,PHI(1:N,MX-1))
		WRITE(*, *) ".... Right-hand side multiplied"
		MAT = INV(M2)
		WRITE(*, *) ".... Matrix M2 inverted"
		PHI(1:N,MX) = MATMUL(MAT,TEMP)
		WRITE(*, *) ".... PHI updated"
		P(1:N,MX-1) = EXP(im*K0*(MX-1)*Dr)*PHI(1:N,MX)*(1/SQRT((MX-1)*Dr))
	END DO
	!-----------------------------------------------------------
	CALL CPU_TIME(TF)
	!-----------------------------------------------------------
	!-----------------------------------------------------------
	!Transmission loss conversion
	P0 = P(NS,1)
	DO MX = 1,M
		DO NZ = 1,N
			LP(NZ,MX) = 20*LOG10(ABS(P(NZ,MX-1)/P0))
		END DO
	END DO
	LPG = LP(1,1:M)
	LP2 = LP/SQRT(2.)
	LPG2 = LP2(1,1:M)
	!-----------------------------------------------------------
	!-----------------------------------------------------------
	!Output
	OPEN(UNIT=10,FILE="GROUNDLVL_TL.dat")
	OPEN(UNIT=20,FILE="FULLFIELD_TL.dat")
	OPEN(UNIT=30,FILE="FULLFIELD_P.dat")
	DO NZ = 1,N
		WRITE(20, 102) LP(NZ,1:M)
		WRITE(30, 101) P(NZ,1:M)
	END DO
	DO MX = 1,M
		WRITE(10, 100) MX*Dr, LPG(MX), LPG2(MX)
	END DO
	100 FORMAT(3(3X,F12.3))
	101 FORMAT(3X,F12.3,SP,F12.3,SS,"i")
	102 FORMAT(100000(3X,F12.3))
	PRINT *, "Main CPU time (s) :", TF-TI
	PRINT *, "Source pressure P0 (dB) :", 20*LOG10(ABS(P0))
	!-----------------------------------------------------------
END PROGRAM PERF2D
!-----------------------------------------------------------
!-------------      EXTERNAL PROCEDURES      ---------------
!-----------------------------------------------------------


!Sort an NXM matrix by a given column using a
!Bubble sort algorithm (slow)

subroutine bubble_sort(A, N, M, isort)
   use params, only: dp
   implicit none
   integer N !Number of rows
   integer M !Number of columns
   real(dp) A(N, M)
   integer isort !column on which to sort rows of matrix
   integer I, J
   real(dp) Temp(M)
   do I = 1, N
      do J = 1, N - 1
         if (A(J, isort) > A(J + 1, isort)) then
            Temp = A(J, :)
            A(J, :) = A(J + 1, :)
            A(J + 1, :) = Temp
         ENDif
      ENDdo
   ENDdo

   RETURN
ENDsubroutine bubble_sort


MODULE invar

! Module to store the AHOT input variables

IMPLICIT NONE
SAVE

! Parallel initialization
INTEGER :: isize, irank

! Title
CHARACTER(80) :: title

! Problem Size Specifications
INTEGER :: lambda, meth, qdord, qdtyp, nxt, nyt, npx, npy, ng, nm
REAL*8, DIMENSION(:), ALLOCATABLE :: dx, dy

! Problem size per block
INTEGER :: nx, ny

! Cell materials
INTEGER, DIMENSION(:,:), ALLOCATABLE :: mat

! Iteration Controls
REAL*8 :: err, tolr
INTEGER :: bitmx, itmx, iall

! Solution check frequency
REAL*8 :: tchk
INTEGER :: ichk

! Extra variables derived from input
INTEGER :: apo, order, ordsq
REAL*8, DIMENSION(:,:), ALLOCATABLE :: ssum

! Angular quadrature input
REAL*8, DIMENSION(:,:), ALLOCATABLE :: ang
REAL*8, DIMENSION(:), ALLOCATABLE :: w

! Boundary Conditions by quadrant (quadrants 1-4 same as basic trig. quadrants)
INTEGER :: q1bc, q2bc, q3bc, q4bc
REAL*8, DIMENSION(:), ALLOCATABLE :: psi1, psi2, psi3, psi4

! Cross section input
REAL*8, DIMENSION(:,:), ALLOCATABLE :: sigt
REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: sigs

! Source data
REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE :: s

! Editing data
INTEGER :: momp, pmoaf

! Parallel Topology setup
INTEGER :: allcomm, xcomm, ycomm, nrank, xrank, yrank
INTEGER, DIMENSION(:), ALLOCATABLE :: nxvec, nyvec

! Solution methodology
INTEGER :: itmflag

! Print the matrix
INTEGER :: matrix

END MODULE


program do_partial_cells
!
! Make sure that partial cells are not too thin.
!
! Usage: do_partial_cells topo_file min_thick min_frac
!
! Ensure that partial cells are greater than max(min_think,min_frac*dzt(kmax))
!

use iso_fortran_env
use netcdf
implicit none

real(real32), dimension(:,:),allocatable :: topog
integer, dimension(:,:),allocatable :: num_levels

real(real64), dimension(:),allocatable ::zeta
real(real32), dimension(:),allocatable ::zw,dz,mdz
real(real32) :: del

integer :: ierr, i,j,k,ni,nj,nzeta,nz,its,counter

integer :: ncid,vid
integer,dimension(2) :: dids

character*32 :: arg
character*128 :: topo_file
real(real32) :: min_thick, min_frac

if (command_argument_count() /= 3) then
   write(*,*) 'ERROR: Wrong number of arguments'
   write(*,*) 'Usage: do_partial_cells topo_file min_thick min_frac'
   stop 1
endif

call get_command_argument(1,topo_file)

call get_command_argument(2,arg)
read(arg,*) min_thick
call get_command_argument(3,arg)
read(arg,*) min_frac

write(*,*) 'Ensuring cell thicknesses are greater than ',min_thick,'m and ',min_frac,'times full thickness'

call handle_error(nf90_open('ocean_vgrid.nc',nf90_nowrite,ncid))
call handle_error(nf90_inq_varid(ncid,'zeta',vid))
call handle_error(nf90_inquire_variable(ncid,vid,dimids=dids))
call handle_error(nf90_inquire_dimension(ncid,dids(1),len=nzeta))

nz=nzeta/2

allocate(zeta(nzeta),zw(0:nz),dz(nz))

call handle_error(nf90_get_var(ncid,vid,zeta))
call handle_error(nf90_close(ncid))

zw(:)=zeta(1:nzeta:2)
dz=zw(1:nz)-zw(0:nz-1)
mdz=min(dz,max(min_frac*dz,min_thick))

call handle_error( nf90_open(trim(topo_file),nf90_write,ncid))
call handle_error(nf90_inq_varid(ncid,'depth',vid))
call handle_error(nf90_inquire_variable(ncid,vid,dimids=dids))
call handle_error(nf90_inquire_dimension(ncid,dids(1),len=ni))
call handle_error(nf90_inquire_dimension(ncid,dids(2),len=nj))

allocate(topog(ni,nj))
allocate(num_levels(ni,nj))
call handle_error(nf90_get_var(ncid,vid,topog))

! Find number of levels

num_levels=0

do j=1,nj
   do i=1,ni
      if(topog(i,j)>0.0) then
         kloop: do k=2,nz
            if(zw(k) >=topog(i,j)) then
               num_levels(i,j)=k
               exit kloop
            endif
          enddo kloop
       endif
   enddo
enddo

do j=1,nj
   do i=1,ni
      k=num_levels(i,j)
      if(k == 0 ) cycle
      if (topog(i,j) == zw(k)) cycle

      del=topog(i,j)-zw(k-1)

!If less than half mininimum allowable thickness shave

      if(del < 0.5*mdz(k)) then
         topog(i,j)=zw(k-1)
         cycle
      endif
! Deep if necessary and make sure there is no rounding problem

      topog(i,j)=min(max(topog(i,j),zw(k-1)+mdz(k)),zw(k))
   enddo
enddo

call handle_error(nf90_redef(ncid))
call handle_error(nf90_put_att(ncid,vid,'min_thick',min_thick))
call handle_error(nf90_put_att(ncid,vid,'min_frac',min_frac))
call handle_error(nf90_enddef(ncid))
call handle_error(nf90_put_var(ncid,vid,topog))
call handle_error(nf90_close(ncid))

contains

subroutine handle_error(error_flag,isfatal,err_string)
! Simple error handle for NetCDF
integer(int32),intent(in) :: error_flag
logical, intent(in),optional :: isfatal
character(*), intent(in),optional :: err_string
logical            :: fatal
fatal = .true.
if(present(isfatal)) fatal=isfatal
if ( error_flag  /= nf90_noerr ) then
   if ( fatal ) then
      write(*,*) 'FATAL ERROR:',nf90_strerror(error_flag)
      if (present(err_string)) write(*,*) trim(err_string)
      stop
   endif
endif
end subroutine handle_error

end program do_partial_cells


!*==zgghrd.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZGGHRD
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGGHRD + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
!                          LDQ, Z, LDZ, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          COMPQ, COMPZ
!       INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
!       ..
!       .. Array Arguments ..
!       COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
!      $                   Z( LDZ, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper
!> Hessenberg form using unitary transformations, where A is a
!> general matrix and B is upper triangular.  The form of the
!> generalized eigenvalue problem is
!>    A*x = lambda*B*x,
!> and B is typically made upper triangular by computing its QR
!> factorization and moving the unitary matrix Q to the left side
!> of the equation.
!>
!> This subroutine simultaneously reduces A to a Hessenberg matrix H:
!>    Q**H*A*Z = H
!> and transforms B to another upper triangular matrix T:
!>    Q**H*B*Z = T
!> in order to reduce the problem to its standard form
!>    H*y = lambda*T*y
!> where y = Z**H*x.
!>
!> The unitary matrices Q and Z are determined as products of Givens
!> rotations.  They may either be formed explicitly, or they may be
!> postmultiplied into input matrices Q1 and Z1, so that
!>      Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H
!>      Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H
!> If Q1 is the unitary matrix from the QR factorization of B in the
!> original equation A*x = lambda*B*x, then ZGGHRD reduces the original
!> problem to generalized Hessenberg form.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] COMPQ
!> \verbatim
!>          COMPQ is CHARACTER*1
!>          = 'N': do not compute Q;
!>          = 'I': Q is initialized to the unit matrix, and the
!>                 unitary matrix Q is returned;
!>          = 'V': Q must contain a unitary matrix Q1 on entry,
!>                 and the product Q1*Q is returned.
!> \endverbatim
!>
!> \param[in] COMPZ
!> \verbatim
!>          COMPZ is CHARACTER*1
!>          = 'N': do not compute Z;
!>          = 'I': Z is initialized to the unit matrix, and the
!>                 unitary matrix Z is returned;
!>          = 'V': Z must contain a unitary matrix Z1 on entry,
!>                 and the product Z1*Z is returned.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrices A and B.  N >= 0.
!> \endverbatim
!>
!> \param[in] ILO
!> \verbatim
!>          ILO is INTEGER
!> \endverbatim
!>
!> \param[in] IHI
!> \verbatim
!>          IHI is INTEGER
!>
!>          ILO and IHI mark the rows and columns of A which are to be
!>          reduced.  It is assumed that A is already upper triangular
!>          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are
!>          normally set by a previous call to ZGGBAL; otherwise they
!>          should be set to 1 and N respectively.
!>          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          On entry, the N-by-N general matrix to be reduced.
!>          On exit, the upper triangle and the first subdiagonal of A
!>          are overwritten with the upper Hessenberg matrix H, and the
!>          rest is set to zero.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX*16 array, dimension (LDB, N)
!>          On entry, the N-by-N upper triangular matrix B.
!>          On exit, the upper triangular matrix T = Q**H B Z.  The
!>          elements below the diagonal are set to zero.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] Q
!> \verbatim
!>          Q is COMPLEX*16 array, dimension (LDQ, N)
!>          On entry, if COMPQ = 'V', the unitary matrix Q1, typically
!>          from the QR factorization of B.
!>          On exit, if COMPQ='I', the unitary matrix Q, and if
!>          COMPQ = 'V', the product Q1*Q.
!>          Not referenced if COMPQ='N'.
!> \endverbatim
!>
!> \param[in] LDQ
!> \verbatim
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.
!>          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
!> \endverbatim
!>
!> \param[in,out] Z
!> \verbatim
!>          Z is COMPLEX*16 array, dimension (LDZ, N)
!>          On entry, if COMPZ = 'V', the unitary matrix Z1.
!>          On exit, if COMPZ='I', the unitary matrix Z, and if
!>          COMPZ = 'V', the product Z1*Z.
!>          Not referenced if COMPZ='N'.
!> \endverbatim
!>
!> \param[in] LDZ
!> \verbatim
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.
!>          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16OTHERcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  This routine reduces A to Hessenberg and B to triangular form by
!>  an unblocked reduction, as described in _Matrix_Computations_,
!>  by Golub and van Loan (Johns Hopkins Press).
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE ZGGHRD(Compq,Compz,N,Ilo,Ihi,A,Lda,B,Ldb,Q,Ldq,Z,Ldz,  &
     &                  Info)
      IMPLICIT NONE
!*--ZGGHRD208
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Compq , Compz
      INTEGER Ihi , Ilo , Info , Lda , Ldb , Ldq , Ldz , N
!     ..
!     .. Array Arguments ..
      COMPLEX*16 A(Lda,*) , B(Ldb,*) , Q(Ldq,*) , Z(Ldz,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16 CONE , CZERO
      PARAMETER (CONE=(1.0D+0,0.0D+0),CZERO=(0.0D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
      LOGICAL ilq , ilz
      INTEGER icompq , icompz , jcol , jrow
      DOUBLE PRECISION c
      COMPLEX*16 ctemp , s
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA , ZLARTG , ZLASET , ZROT
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC DCONJG , MAX
!     ..
!     .. Executable Statements ..
!
!     Decode COMPQ
!
      IF ( LSAME(Compq,'N') ) THEN
         ilq = .FALSE.
         icompq = 1
      ELSEIF ( LSAME(Compq,'V') ) THEN
         ilq = .TRUE.
         icompq = 2
      ELSEIF ( LSAME(Compq,'I') ) THEN
         ilq = .TRUE.
         icompq = 3
      ELSE
         icompq = 0
      ENDIF
!
!     Decode COMPZ
!
      IF ( LSAME(Compz,'N') ) THEN
         ilz = .FALSE.
         icompz = 1
      ELSEIF ( LSAME(Compz,'V') ) THEN
         ilz = .TRUE.
         icompz = 2
      ELSEIF ( LSAME(Compz,'I') ) THEN
         ilz = .TRUE.
         icompz = 3
      ELSE
         icompz = 0
      ENDIF
!
!     Test the input parameters.
!
      Info = 0
      IF ( icompq<=0 ) THEN
         Info = -1
      ELSEIF ( icompz<=0 ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Ilo<1 ) THEN
         Info = -4
      ELSEIF ( Ihi>N .OR. Ihi<Ilo-1 ) THEN
         Info = -5
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -9
      ELSEIF ( (ilq .AND. Ldq<N) .OR. Ldq<1 ) THEN
         Info = -11
      ELSEIF ( (ilz .AND. Ldz<N) .OR. Ldz<1 ) THEN
         Info = -13
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGGHRD',-Info)
         RETURN
      ENDIF
!
!     Initialize Q and Z if desired.
!
      IF ( icompq==3 ) CALL ZLASET('Full',N,N,CZERO,CONE,Q,Ldq)
      IF ( icompz==3 ) CALL ZLASET('Full',N,N,CZERO,CONE,Z,Ldz)
!
!     Quick return if possible
!
      IF ( N<=1 ) RETURN
!
!     Zero out lower triangle of B
!
      DO jcol = 1 , N - 1
         DO jrow = jcol + 1 , N
            B(jrow,jcol) = CZERO
         ENDDO
      ENDDO
!
!     Reduce A and B
!
      DO jcol = Ilo , Ihi - 2
!
         DO jrow = Ihi , jcol + 2 , -1
!
!           Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
!
            ctemp = A(jrow-1,jcol)
            CALL ZLARTG(ctemp,A(jrow,jcol),c,s,A(jrow-1,jcol))
            A(jrow,jcol) = CZERO
            CALL ZROT(N-jcol,A(jrow-1,jcol+1),Lda,A(jrow,jcol+1),Lda,c, &
     &                s)
            CALL ZROT(N+2-jrow,B(jrow-1,jrow-1),Ldb,B(jrow,jrow-1),Ldb, &
     &                c,s)
            IF ( ilq ) CALL ZROT(N,Q(1,jrow-1),1,Q(1,jrow),1,c,DCONJG(s)&
     &                           )
!
!           Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
!
            ctemp = B(jrow,jrow)
            CALL ZLARTG(ctemp,B(jrow,jrow-1),c,s,B(jrow,jrow))
            B(jrow,jrow-1) = CZERO
            CALL ZROT(Ihi,A(1,jrow),1,A(1,jrow-1),1,c,s)
            CALL ZROT(jrow-1,B(1,jrow),1,B(1,jrow-1),1,c,s)
            IF ( ilz ) CALL ZROT(N,Z(1,jrow),1,Z(1,jrow-1),1,c,s)
         ENDDO
      ENDDO
!
!
!     End of ZGGHRD
!
      END SUBROUTINE ZGGHRD


program test_excess_mpi

use, intrinsic :: iso_fortran_env, only : stderr=>error_unit

use autogrid, only : checker=>test_process_number, max_mpi

implicit none (type, external)

call check_autogrid()

call check_auto_mpi()

contains

subroutine check_autogrid()

integer :: i
logical :: all_ok
integer, allocatable, dimension(:) :: rx2, rx3, N

all_ok = .true.

!> 2D
rx2 = [1,1,1,1,1, 1, 1, 1]
rx3 = [1,2,4,5,8,10,20,40]
N   = [1,2,4,5,8,10,20,40]
do i = 1,size(N)
  if (.not. checker(N(i), lx2all=1, lx3all=40, rx2=rx2(i), rx3=rx3(i))) all_ok = .false.
  if (.not. checker(N(i), lx2all=40, lx3all=1, rx2=rx3(i), rx3=rx2(i))) all_ok = .false.
enddo

!> 3D

rx2 = [1,1,2,2,2, 4, 4]
rx3 = [1,2,2,3,4, 3, 6]
N   = [1,2,4,6,8,12,24]
do i = 1,size(N)
  if (.not. checker(N(i), lx2all=8, lx3all=12, rx2=rx2(i), rx3=rx3(i))) all_ok = .false.
enddo

rx2 = [1,1,2,3,2, 3]
rx3 = [1,2,2,2,4, 4]
N   = [1,2,4,6,8,12]
do i = 1,size(N)
  if (.not. checker(N(i), lx2all=6, lx3all=8, rx2=rx2(i), rx3=rx3(i))) all_ok = .false.
enddo

rx2 = [1,1,2,5,2, 4, 5, 5, 10]
rx3 = [1,2,2,1,4, 4, 4, 8,  8]
N   = [1,2,4,5,8,16,20,40, 80]
do i = 1,size(N)
  if (.not. checker(N(i), lx2all=20, lx3all=16, rx2=rx2(i), rx3=rx3(i))) all_ok = .false.
enddo

rx2 = [1,1,2,2,4, 4, 2, 4, 4,11,  4, 11, 11, 22]
rx3 = [1,2,2,3,2, 3, 9, 6, 9, 9, 27, 18, 27, 27]
N   = [1,2,4,6,8,12,18,24,36,99,108,198,297,594]
do i = 1,size(N)
  if (.not. checker(N(i), lx2all=44, lx3all=54, rx2=rx2(i), rx3=rx3(i))) all_ok = .false.
enddo

rx2 = [1,1,2,3,2, 3, 9, 6, 9, 9, 27, 18, 27, 27]
rx3 = [1,2,2,2,4, 4, 2, 4, 4,11,  4, 11, 11, 22]
N   = [1,2,4,6,8,12,18,24,36,99,108,198,297,594]
do i = 1,size(N)
  if (.not. checker(N(i), lx2all=54, lx3all=44, rx2=rx2(i), rx3=rx3(i))) all_ok = .false.
enddo

if (.not. all_ok) error stop 'process_grid_auto mismatch'

print *, 'OK: auto process grid'

end subroutine check_autogrid

subroutine check_auto_mpi()

integer :: i, j, O
integer,parameter :: &
L(3) = [4,16,40], &  !< length of dimension
N(3) = [4,28,96], & !< number of CPU cores
M(3,3) = reshape(&    !< expected auto-selected number of MPI images
[2, 2, 2, &
 4, 8, 8, &
 4, 20, 20], shape=shape(M), order=[2,1])

if (max_mpi(100,52, 1) /= 1) error stop "gcd(N,1) /= 1"

if (max_mpi(6, 8, 32) /= 12) error stop "max_mpi(6,8,32) /= 12"

do i = 1,size(L)
  do j = 1,size(N)
    O = max_mpi(L(i), 1, N(j))
    if (O /= M(i,j)) then
      write(stderr,*) "ERROR:max_mpi",L(i),N(j),M(i,j),O
      error stop
    endif
    if (M(i,j) /= max_mpi(1, L(i), N(j))) error stop 'max_mpi value error'
  enddo
enddo

print *, "OK: max_mpi"

end subroutine check_auto_mpi

end program


module fcn_pressure_pulse
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FIVE, EIGHT, PI
    use type_point,     only: point_t
    use type_point_ad,  only: point_ad_t
    use type_function,  only: function_t
    use DNAD_D
    implicit none
    private

    !>  This function defines an analytical solution to the 2D Euler equations.
    !!  It may be used to provide initial conditions for an unsteady simulation,
    !!  as well as to compute numerical errors.
    !!
    !!  This solution is implemented as in Fidkowski 2016
    !!
    !!  @author Eric Wolf
    !!  @date   2/15/2017
    !!
    !!
    !-------------------------------------------------------------------------------
    type, extends(function_t), public :: pressure_pulse_f

        real(rk)    :: x0 = 0.0_rk
        real(rk)    :: y0 = 0.0_rk
        real(rk)    :: z0 = 0.0_rk

        real(rk)    :: uinf   = ZERO
        real(rk)    :: vinf   = ZERO
        real(rk)    :: winf   = ZERO
        real(rk)    :: rhoinf = ONE
        real(rk)    :: pinf   = ONE/1.4_rk

        integer(ik) :: ivar

    contains

        procedure   :: init
        procedure   :: compute

    end type pressure_pulse_f
    !********************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(pressure_pulse_f),  intent(inout)  :: self

        ! Set function name
        call self%set_name("pressure_pulse")

        call self%add_option('ivar', 1._rk)

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !!
    !-----------------------------------------------------------------------------------------
    impure elemental function compute(self,time,coord) result(val)
        class(pressure_pulse_f),    intent(inout)   :: self
        real(rk),                   intent(in)      :: time
        type(point_ad_t),           intent(in)      :: coord

        type(AD_D)  :: x, y, z, r, &
                       u, v, w, &
                       rho, p, drho, dp, val

        integer(ik) :: ivar
        real(rk)    :: b, gam

        x   = coord%c1_
        y   = coord%c2_
        z   = coord%c3_
        b   = 0.01_rk
        gam = 1.4_rk

        !r = x
        !r = sqrt(x*x + y*y)
        r = sqrt(x*x + z*z)
        drho = 0.1_rk * exp(-(log(TWO)/b)*r*r)
        dp   = drho/gam

        rho = self%rhoinf + drho
        p   = self%pinf   + dp
        u   = ZERO
        v   = ZERO
        w   = ZERO

        ivar = nint(self%get_option_value('ivar'))
        select case (ivar)
            ! RHO
            case (1)
                val = rho

            ! RHO-U
            case (2)
                val = ZERO

            ! RHO-V
            case (3)
                val = ZERO

            ! RHO-W
            case (4)
                val = ZERO

            ! RHO-E
            case (5)
                val = p/(gam-ONE)  +  HALF*rho*(u*u + v*v + w*w)

            ! Pressure_TEMP
            case (6)
                val = p

            ! Grad1 P
            case (7)
                val = -13.8629*x*exp(-69.3147_rk*r*r)

            ! Grad2 P
            case (8)
                val = ZERO

            ! Grad3 P
            case (9)
                val = -13.8629*z*exp(-69.3147_rk*r*r)

        end select

    end function compute
    !**********************************************************************************

end module fcn_pressure_pulse


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c ... file shsgs.f
c
c     this file contains code and documentation for subroutines
c     shsgs and shsgsi
c
c ... files which must be loaded with shsgs.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     subroutine shsgs(nstrg,nstrab,noffsg,noffsab,
c                      nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    1                 mdabmax,ndabmax,
c    1                    wshsgs,lshsgs,work,lwork,ierror)
c
c     subroutine shsgs performs the spherical harmonic synthesis
c     on the arrays a and b and stores the result in the array g.
c     the synthesis is performed on an equally spaced longitude grid
c     and a gaussian colatitude grid.  the associated legendre functions
c     are stored rather than recomputed as they are in subroutine
c     shsgc.  the synthesis is described below at output parameter
c     g.
c
c
c     input parameters
c
c     nstrg,nstrab   stride in g,a,b
c     noffsg,noffsab offset in g,a,b -- must be between 0 and stride-1
c            Alternatively, when the two strides equal, you can set both
c            to -1 in which case the output will be computed for all
c            values of offset between 0 and stride-1.
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     NOTE: this is a modified version of spherepack.  Changes from
c           the original version to the current one have only been
c           tested for isym==0.  For this reason an error code will
c           be returned if isym!=0.
c
c     isym   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the synthesis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the synthesis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of syntheses.  in the program that calls shsgs,
c            the arrays g,a and b can be three dimensional in which
c            case multiple synthesis will be performed.  the third
c            index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that the arrays g,a and b
c            have only two dimensions.
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shagc. if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg must
c            be at least nlat/2 if nlat is even or at least (nlat+1)/2
c            if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shagc. jdg must be at least nlon.
c
c     a,b    two or three dimensional arrays (see the input parameter
c            nt) that contain the coefficients in the spherical harmonic
c            expansion of g(i,j) given below at the definition of the
c            output parameter g.  a(m,n) and b(m,n) are defined for
c            indices m=1,...,mmax and n=m,...,nlat where mmax is the
c            maximum (plus one) longitudinal wave number given by
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shsgs. mdab must be at least
c            min0((nlon+2)/2,nlat) if nlon is even or at least
c            min0((nlon+1)/2,nlat) if nlon is odd IF IT CONTAINS
c            ALL COEFFICIENTS.  If smaller, the higher coefficients
c            are ignored (i.e., treated as if they were zero).
c
c     ndab   the second dimension of the arrays a and b as it appears
c            in the program that calls shsgs. ndab must be at least nlat
c            IF IT CONTAINS ALL COEFFICIENTS. Otherwise the higher coefs
c            are ignored (i.e., treated as if they were zero).
c
c     mdabmax, ndabmax -- will ignore coefficients a,b with index higher
c            than these
c
c     wshsgs an array which must be initialized by subroutine shsgsi.
c            once initialized, wshsgs can be used repeatedly by shsgs
c            as long as nlat and nlon remain unchanged.  wshsgs must
c            not be altered between calls of shsgs.
c
c     lshsgs the dimension of the array wshsgs as it appears in the
c            program that calls shsgs. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsgs must be at least
c
c            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
c
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shsgs. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c
c            if isym is zero then lwork must be at least
c
c                  nlat*nlon*(nt+1)
c
c            if isym is nonzero then lwork must be at least
c
c                  l2*nlon*(nt+1)
c
c
c     **************************************************************
c
c     output parameters
c
c     g      a two or three dimensional array (see input parameter nt)
c            that contains the discrete function which is synthesized.
c            g(i,j) contains the value of the function at the gaussian
c            colatitude point theta(i) and longitude point
c            phi(j) = (j-1)*2*pi/nlon. the index ranges are defined
c            above at the input parameter isym.  for isym=0, g(i,j)
c            is given by the the equations listed below.  symmetric
c            versions are used when isym is greater than zero.
c
c     the normalized associated legendre functions are given by
c
c     pbar(m,n,theta) = dsqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta)
c
c     define the maximum (plus one) longitudinal wave number
c     as   mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c          mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     then g(i,j) = the sum from n=0 to n=nlat-1 of
c
c                   .5*pbar(0,n,theta(i))*a(1,n+1)
c
c              plus the sum from m=1 to m=mmax-1 of
c
c                   the sum from n=m to n=nlat-1 of
c
c              pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j))
c                                    -b(m+1,n+1)*sin(m*phi(j)))
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 9  error in the specification of lshsgs
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c
c     subroutine shsgsi(nlat,nlon,wshsgs,lshsgs,work,lwork,dwork,ldwork,
c    +                  ierror)
c
c     subroutine shsgsi initializes the array wshsgs which can then
c     be used repeatedly by subroutines shsgs. it precomputes
c     and stores in wshsgs quantities such as gaussian weights,
c     legendre polynomial coefficients, and fft trigonometric tables.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     wshsgs an array which must be initialized by subroutine shsgsi.
c            once initialized, wshsgs can be used repeatedly by shsgs
c            as long as nlat and nlon remain unchanged.  wshsgs must
c            not be altered between calls of shsgs.
c
c     lshsgs the dimension of the array wshsgs as it appears in the
c            program that calls shsgs. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsgs must be at least
c
c            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
c
c     work   a real work space which need not be saved
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shsgsi. lwork must be at least
c            4*nlat*(nlat+2)+2 in the routine calling shsgsi
c
c     dwork   a double precision work array that does not have to be saved.
c
c     ldwork  the length of dwork in the calling routine.  ldwork must
c             be at least nlat*(nlat+4)
c
c     output parameter
c
c     wshsgs an array which must be initialized before calling shsgs or
c            once initialized, wshsgs can be used repeatedly by shsgs or
c            as long as nlat and nlon remain unchanged.  wshsgs must not
c            altered between calls of shsgs.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshsgs
c            = 4  error in the specification of lwork
c            = 5  error in the specification of ldwork
c            = 5  failure in gaqd to compute gaussian points
c                 (due to failure in eigenvalue routine)
c
c
      subroutine shsgs(nstrg,nstrab,noffsg,noffsab,
     1                 nlat,nlon,mode,nt,g,idg,jdg,a,b,mdab,ndab,
     1                 mdabmax,ndabmax,wshsgs,lshsgs,work,lwork,ierror)
      implicit double precision (a-h,o-z)
      dimension g(nstrg,idg,jdg,1),a(nstrab,mdab,ndab,1),
     1          b(nstrab,mdab,ndab,1),wshsgs(lshsgs),work(lwork)
c     check input parameters
      ierror = 1
      if (nlat.lt.3) return
      ierror = 2
      if (nlon.lt.4) return
      ierror = 3
c     if (mode.lt.0 .or.mode.gt.2) return
c     see note about isym above
      if (mode.ne.0) return
      ierror = 4
      if (nt.lt.1) return
c     set limit on m subscript
      l = min0((nlon+2)/2,nlat)
c     set gaussian point nearest equator pointer
      late = (nlat+mod(nlat,2))/2
c     set number of grid points for analysis/synthesis
      lat = nlat
      if (mode.ne.0) lat = late
      ierror = 5
      if (idg.lt.lat) return
      ierror = 6
      if (jdg.lt.nlon) return
c     ierror = 7
c     if(mdab .lt. l) return
c     ierror = 8
c     if(ndab .lt. nlat) return
      l1 = l
      l2 = late
      ierror = 9
c     check permanent work space length
      lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
      if(lshsgs.lt.lp) return
c     check temporary work space length
      ng = 1;
      if(noffsg.eq.-1 .and. noffsab.eq.-1) ng=nstrg
      ierror = 10
      if (mode.eq.0 .and. lwork.lt.ng*nlat*nlon*(nt+1)) return
      if (mode.ne.0 .and. lwork.lt.ng*l2*nlon*(nt+1)) return
      ierror = 11
      if((noffsg.eq.-1) .neqv. (noffsab.eq.-1)) return
      if((noffsg.eq.-1) .and.  (nstrg.ne.nstrab)) return
      if((noffsg.lt.-1) .or.  (noffsg.ge.nstrg)) return
      if((noffsab.lt.-1) .or.  (noffsab.ge.nstrab)) return
      ierror = 0
c     starting address for fft values and legendre polys in wshsgs
      ifft = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+1
      ipmn = ifft+nlon+15
c     set pointer for internal storage of g
      iw = ng*lat*nlon*nt+1
      call shsgs1(nstrg,nstrab,noffsg,noffsab,
     1            nlat,nlon,l,lat,mode,g,idg,jdg,nt,a,b,mdab,ndab,
     1            mdabmax,ndabmax,
     1            wshsgs(ifft),wshsgs(ipmn),late,work,ng,work(iw))
      return
      end

      subroutine shsgs1(nstrgs,nstrab,noffsgs,noffsab,
     1                  nlat,nlon,l,lat,mode,gs,idg,jdg,nt,a,b,mdab,
     1                  ndab,mdabmax,ndabmax,wfft,pmn,late,g,ng,work)
      implicit double precision (a-h,o-z)
      dimension gs(nstrgs,idg,jdg,nt),
     1   a(nstrab,mdab,ndab,nt),b(nstrab,mdab,ndab,nt)
      dimension wfft(1),pmn(late,1),g(ng,lat,nlon,nt),work(1)
      nlatmax=min0(nlat,ndabmax)

c     ncgs=1+noffsgs
c     ncab=1+noffsab

      if(noffsgs.eq.-1) then
      ioffset0=2
      ioffset1=nstrgs+1
      else
      ioffset0=1
      ioffset1=1
      end if

c     reconstruct fourier coefficients in g on gaussian grid
c     using coefficients in a,b

c     initialize to zero
      do 100 k=1,nt
      do 100 j=1,nlon
      do 100 i=1,lat
      do 100 ig=1,ng
      g(ig,i,j,k) = 0.0d0
  100 continue

      lm1 = l
      if (nlon .eq. l+l-2) lm1 = l-1

      mp1max = min0(lm1,mdabmax)

      if (mode.eq.0) then

c     do 201 ioffset=ioffset0,ioffset1
c     ncab=noffsab+ioffset
c     ig=ioffset-ioffset0+1

c     set first column in g
      m = 0
      mml1 = m*(2*nlat-m-1)/2
      do 101 k=1,nt
c     n even
      do 102 np1=1,nlatmax,2
      mn = mml1+np1
      do 102 i=1,late
      do 102 ioffset=ioffset0,ioffset1
      ncab=noffsab+ioffset
      ig=ioffset-ioffset0+1
      g(ig,i,1,k) = g(ig,i,1,k)+a(ncab,1,np1,k)*pmn(i,mn)
  102 continue
c     n odd
      nl2 = nlat/2
      if(nlatmax.ge.2) then
      do 103 np1=2,nlatmax,2
      mn = mml1+np1
      do 103 i=1,nl2
      is = nlat-i+1
      do 103 ioffset=ioffset0,ioffset1
      ncab=noffsab+ioffset
      ig=ioffset-ioffset0+1
      g(ig,is,1,k) = g(ig,is,1,k)+a(ncab,1,np1,k)*pmn(i,mn)
  103 continue
      end if
  101 continue

c     restore m=0 coefficients from odd/even
      do 112 k=1,nt
      do 112 i=1,nl2
      do 112 ig=1,ng
      is = nlat-i+1
      t1 = g(ig,i,1,k)
      t3 = g(ig,is,1,k)
      g(ig,i,1,k) = t1+t3
      g(ig,is,1,k) = t1-t3
  112 continue

c     sweep interior columns of g
      if(mp1max.ge.2) then
      do 104 mp1=2,mp1max
      m = mp1-1
      mml1 = m*(2*nlat-m-1)/2
      mp2 = m+2
      do 105 k=1,nt
c     for n-m even store (g(i,p,k)+g(nlat-i+1,p,k))/2 in g(i,p,k) p=2*m,2*m+1
c     for i=1,...,late
      if(nlatmax.ge.mp1) then
      do 106 np1=mp1,nlatmax,2
      mn = mml1+np1
      do 107 i=1,late
      do 107 ioffset=ioffset0,ioffset1
      ncab=noffsab+ioffset
      ig=ioffset-ioffset0+1
      g(ig,i,2*m,k) = g(ig,i,2*m,k)+a(ncab,mp1,np1,k)*pmn(i,mn)
      g(ig,i,2*m+1,k) = g(ig,i,2*m+1,k)+b(ncab,mp1,np1,k)*pmn(i,mn)
  107 continue
  106 continue
      end if

c     for n-m odd store g(i,p,k)-g(nlat-i+1,p,k) in g(nlat-i+1,p,k)
c     for i=1,...,nlat/2 (p=2*m,p=2*m+1)
      if(nlatmax.ge.mp2) then
      do 108 np1=mp2,nlatmax,2
      mn = mml1+np1
      do 109 i=1,nl2
      is = nlat-i+1
      do 109 ioffset=ioffset0,ioffset1
      ncab=noffsab+ioffset
      ig=ioffset-ioffset0+1
      g(ig,is,2*m,k) = g(ig,is,2*m,k)+a(ncab,mp1,np1,k)*pmn(i,mn)
      g(ig,is,2*m+1,k) = g(ig,is,2*m+1,k)+b(ncab,mp1,np1,k)*pmn(i,mn)
  109 continue
  108 continue
      end if

c     now set fourier coefficients using even-odd reduction above
      do 110 i=1,nl2
      do 110 ig=1,ng
      is = nlat-i+1
      t1 = g(ig,i,2*m,k)
      t2 = g(ig,i,2*m+1,k)
      t3 = g(ig,is,2*m,k)
      t4 = g(ig,is,2*m+1,k)
      g(ig,i,2*m,k) = t1+t3
      g(ig,i,2*m+1,k) = t2+t4
      g(ig,is,2*m,k) = t1-t3
      g(ig,is,2*m+1,k) = t2-t4
  110 continue

  105 continue
  104 continue
      end if

c     set last column (using a only) if necessary
      if (nlon.eq. l+l-2) then
      if (l.le.mdabmax) then
      m = l-1
      mml1 = m*(2*nlat-m-1)/2
      do 111 k=1,nt
c     n-m even
      if(nlatmax.ge.l) then
      do 131 np1=l,nlatmax,2
      mn = mml1+np1
      do 131 i=1,late
      do 131 ioffset=ioffset0,ioffset1
      ncab=noffsab+ioffset
      ig=ioffset-ioffset0+1
      g(ig,i,nlon,k) = g(ig,i,nlon,k)+2.0d0*a(ncab,l,np1,k)*pmn(i,mn)

  131 continue
      end if
      lp1 = l+1
c     n-m odd
      if(nlatmax.ge.lp1) then
      do 132 np1=lp1,nlatmax,2
      mn = mml1+np1
      do 132 i=1,nl2
      is = nlat-i+1
      do 132 ioffset=ioffset0,ioffset1
      ncab=noffsab+ioffset
      ig=ioffset-ioffset0+1
      g(ig,is,nlon,k) = g(ig,is,nlon,k)+2.0d0*a(ncab,l,np1,k)*pmn(i,mn)
  132 continue
      end if
      do 133 i=1,nl2
      do 133 ig=1,ng
      is = nlat-i+1
      t1 = g(ig,i,nlon,k)
      t3 = g(ig,is,nlon,k)
      g(ig,i,nlon,k)= t1+t3
      g(ig,is,nlon,k)= t1-t3
  133 continue
  111 continue
      end if
      end if
  201 continue

      else
c     half sphere (mode.ne.0)

c     set first column in g
      m = 0
      mml1 = m*(2*nlat-m-1)/2
      meo = 1
      if (mode.eq.1) meo = 2
      ms = m+meo
      if(nlatmax.ge.ms) then
      do 113 k=1,nt
      do 113 np1=ms,nlatmax,2
      mn = mml1+np1
      do 113 i=1,late
      do 113 ioffset=ioffset0,ioffset1
      ncab=noffsab+ioffset
      ig=ioffset-ioffset0+1
      g(ig,i,1,k) = g(ig,i,1,k)+a(ncab,1,np1,k)*pmn(i,mn)
  113 continue
      end if

c     sweep interior columns of g

      if(mp1max.ge.2) then
      do 114 mp1=2,mp1max
      m = mp1-1
      mml1 = m*(2*nlat-m-1)/2
      ms = m+meo
      if(nlatmax.ge.ms) then
      do 115 k=1,nt
      do 115 np1=ms,nlatmax,2
      mn = mml1+np1
      do 115 i=1,late
      do 115 ioffset=ioffset0,ioffset1
      ncab=noffsab+ioffset
      ig=ioffset-ioffset0+1
      g(ig,i,2*m,k) = g(ig,i,2*m,k)+a(ncab,mp1,np1,k)*pmn(i,mn)
      g(ig,i,2*m+1,k) = g(ig,i,2*m+1,k)+b(ncab,mp1,np1,k)*pmn(i,mn)
  115 continue
      end if
  114 continue
      end if

      if (nlon.eq.l+l-2 .and. l.le.mdabmax) then
c     set last column
      m = l-1
      mml1 = m*(2*nlat-m-1)/2
      ns = l
      if (mode.eq.1) ns = l+1
      if(nlatmax.ge.ns) then
      do 116 k=1,nt
      do 116 np1=ns,nlatmax,2
      mn = mml1+np1
      do 116 i=1,late
      do 116 ioffset=ioffset0,ioffset1
      ncab=noffsab+ioffset
      ig=ioffset-ioffset0+1
      g(ig,i,nlon,k) = g(ig,i,nlon,k)+2.0d0*a(ncab,l,np1,k)*pmn(i,mn)
  116 continue
      end if
      end if
  202 continue

      end if

c     do inverse fourier transform
      do 120 k=1,nt
      call hrfftb(ng*lat,nlon,g(1,1,1,k),ng*lat,wfft,work)
  120 continue
c     scale output in gs
      do 122 k=1,nt
      do 122 j=1,nlon
      do 122 i=1,lat
      do 122 ioffset=ioffset0,ioffset1
      ncgs=noffsgs+ioffset
      ig=ioffset-ioffset0+1
      gs(ncgs,i,j,k) = 0.5d0*g(ig,i,j,k)
  122 continue

      return
      end
      subroutine shsgsi(nlat,nlon,wshsgs,lshsgs,work,lwork,dwork,ldwork,
     +                  ierror)
      implicit double precision (a-h,o-z)
c
c     this subroutine must be called before calling shags or shsgs with
c     fixed nlat,nlon. it precomputes the gaussian weights, points
c     and all necessary legendre polys and stores them in wshsgs.
c     these quantities must be preserved when calling shsgs
c     repeatedly with fixed nlat,nlon.
c
      dimension wshsgs(lshsgs),work(lwork)
      double precision dwork(ldwork)
      ierror = 1
      if (nlat.lt.3) return
      ierror = 2
      if (nlon.lt.4) return
c     set triangular truncation limit for spherical harmonic basis
      l = min0((nlon+2)/2,nlat)
c     set equator or nearest point (if excluded) pointer
      late = (nlat+1)/2
      l1 = l
      l2 = late
c     check permanent work space length
      ierror = 3
      lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
      if(lshsgs.lt.lp) return
      ierror = 4
c     check temporary work space
      if (lwork.lt.4*nlat*(nlat+2)+2) return
      ierror = 5
      if (ldwork .lt. nlat*(nlat+4)) return
      ierror = 0
c     set preliminary quantites needed to compute and store legendre polys
      ldw = nlat*(nlat+4)
      call shsgsp(nlat,nlon,wshsgs,lshsgs,dwork,ldwork,ierror)
      if (ierror.ne.0) return
c     set legendre poly pointer in wshsgs
      ipmnf = nlat+2*nlat*late+3*(l*(l-1)/2+(nlat-l)*(l-1))+nlon+16
      call shsgss1(nlat,l,late,wshsgs,work,wshsgs(ipmnf))
      return
      end
      subroutine shsgss1(nlat,l,late,w,pmn,pmnf)
      implicit double precision (a-h,o-z)
      dimension w(1),pmn(nlat,late,3),pmnf(late,1)
c     compute and store legendre polys for i=1,...,late,m=0,...,l-1
c     and n=m,...,l-1
      do i=1,nlat
	do j=1,late
	  do k=1,3
	    pmn(i,j,k) = 0.0d0
	  end do
	 end do
      end do
      km0=1
      km1=2
      km2=3
      do 100 mp1=1,l
      m = mp1-1
      mml1 = m*(2*nlat-m-1)/2
c     compute pmn for n=m,...,nlat-1 and i=1,...,(l+1)/2
      mode = 0
      call legin(mode,l,nlat,m,w,pmn,km,km0,km1,km2)
c     store above in pmnf
      do 101 np1=mp1,nlat
      mn = mml1+np1
      do 102 i=1,late
      pmnf(i,mn) = pmn(np1,i,km)
  102 continue
  101 continue
  100 continue
      return
      end
      subroutine shsgsp(nlat,nlon,wshsgs,lshsgs,dwork,ldwork,ierror)
      implicit double precision (a-h,o-z)
      dimension wshsgs(lshsgs)
      double precision dwork(ldwork)
      ierror = 1
      if (nlat.lt.3) return
      ierror = 2
      if (nlon.lt.4) return
c     set triangular truncation limit for spherical harmonic basis
      l = min0((nlon+2)/2,nlat)
c     set equator or nearest point (if excluded) pointer
      late = (nlat+mod(nlat,2))/2
      l1 = l
      l2 = late
      ierror = 3
c     check permanent work space length
      if (lshsgs .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return
      ierror = 4
c     if (lwork.lt.4*nlat*(nlat+2)+2) return
      if (ldwork .lt. nlat*(nlat+4)) return
      ierror = 0
c     set pointers
      i1 = 1
      i2 = i1+nlat
      i3 = i2+nlat*late
      i4 = i3+nlat*late
      i5 = i4+l*(l-1)/2 +(nlat-l)*(l-1)
      i6 = i5+l*(l-1)/2 +(nlat-l)*(l-1)
      i7 = i6+l*(l-1)/2 +(nlat-l)*(l-1)
c     set indices in temp work for double precision gaussian wts and pts
      idth = 1
c     idwts = idth+2*nlat
c     iw = idwts+2*nlat
      idwts = idth+nlat
      iw = idwts+nlat
      call shsgsp1(nlat,nlon,l,late,wshsgs(i1),wshsgs(i2),wshsgs(i3),
     1wshsgs(i4),wshsgs(i5),wshsgs(i6),wshsgs(i7),dwork(idth),
     2dwork(idwts),dwork(iw),ierror)
      if (ierror.ne.0) ierror = 6
      return
      end
      subroutine shsgsp1(nlat,nlon,l,late,wts,p0n,p1n,abel,bbel,cbel,
     +                   wfft,dtheta,dwts,work,ier)
      implicit double precision (a-h,o-z)
      dimension wts(nlat),p0n(nlat,late),p1n(nlat,late),abel(1),bbel(1),
     1 cbel(1),wfft(1),dtheta(nlat),dwts(nlat)
      double precision pb,dtheta,dwts,work(*)
      indx(m,n) = (n-1)*(n-2)/2+m-1
      imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1
      call hrffti(nlon,wfft)
c
c     compute double precision gaussian points and weights
c
      lw = nlat*(nlat+2)
      call gaqd(nlat,dtheta,dwts,work,lw,ier)
      if (ier.ne.0) return

c     store gaussian weights single precision to save computation
c     in inner loops in analysis
      do 100 i=1,nlat
      wts(i) = dwts(i)
  100 continue

c     initialize p0n,p1n using double precision dnlfk,dnlft
      do 101 np1=1,nlat
      do 101 i=1,late
      p0n(np1,i) = 0.0d0
      p1n(np1,i) = 0.0d0
  101 continue
c     compute m=n=0 legendre polynomials for all theta(i)
      np1 = 1
      n = 0
      m = 0
      call dnlfk(m,n,work)
      do 103 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p0n(1,i) = pb
  103 continue
c     compute p0n,p1n for all theta(i) when n.gt.0
      do 104 np1=2,nlat
      n = np1-1
      m = 0
      call dnlfk(m,n,work)
      do 105 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p0n(np1,i) = pb
  105 continue
c     compute m=1 legendre polynomials for all n and theta(i)
      m = 1
      call dnlfk(m,n,work)
      do 106 i=1,late
      call dnlft(m,n,dtheta(i),work,pb)
      p1n(np1,i) = pb
  106 continue
  104 continue
c
c     compute and store swarztrauber recursion coefficients
c     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      do 107 n=2,nlat
      mlim = min0(n,l)
      do 107 m=2,mlim
      imn = indx(m,n)
      if (n.ge.l) imn = imndx(m,n)
      abel(imn)=dsqrt(dfloat((2*n+1)*(m+n-2)*(m+n-3))/
     1               dfloat(((2*n-3)*(m+n-1)*(m+n))))
      bbel(imn)=dsqrt(dfloat((2*n+1)*(n-m-1)*(n-m))/
     1               dfloat(((2*n-3)*(m+n-1)*(m+n))))
      cbel(imn)=dsqrt(dfloat((n-m+1)*(n-m+2))/
     1               dfloat(((n+m-1)*(n+m))))
  107 continue
      return
      end


c
c     file resc3sp.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c     subroutine resc3sp(nx,ny,nz,nxa,nxb,nyc,nyd,nze,nzf,work,res)
c
c
c ... purpose
c
c
c     subroutine resc3sp computes the fine grid residual in the nx by ny by nz
c     array res after calling cud3sp.  if
c
c          l * p = f
c
c     is the n by n (n = nx*ny*nz) block tri-diagonal linear system resulting
c     from the pde discretization (done internally in cud3sp) and phi is the
c     approximation to p obtained by calling cud3sp, then resc3sp computes
c     the nx by ny by nz residual array
c
c          res = f - l * phi.
c
c     one of the vector norms of res,
c
c          || res ||
c
c     can be computed as a "measure" of how well phi satisfies the
c     discretization equations.  for example, the following statements
c     will compute the location and size of the maximum residual in res
c     on cray computers:
c
c          ijk = isamax(nx*ny*nz,res,1)
c
c          kmax = (ijk-1)/(nx*ny) + 1
c
c          jmax = (ijk-(kmax-1)*nx*ny-1)/nx + 1
c
c          imax = ij - nx*((kmax-1)*ny-jmax+1)
c
c          resmax = abs(res(imax,jmax,kmax))
c
c
c *** please note:
c
c          let pe be the exact continuous solution to the elliptic pde
c          evaluated on the nx by ny by nz discretization grid
c
c          let p be the exact solution to the linear discretization
c
c          let phi be the approximation to p generated by the mudpack solver
c
c     then discretization level error is defined by the condition
c
c          || phi - p || < || p - pe ||.
c                        =
c
c     a common measure of multigrid efficieny is that discretization level
c     error is reached in one full multigrid cycle (see references [2,9] in
c     the mudpack file "readme").  this can happen before the residual is
c     reduced to the level of roundoff error.  consequently, || res || is
c     a conservative measure of accuracy which can be wasteful if multi-
c     grid cycles are executed until it reaches the level of roundoff error.
c
c     || res || can be used to estimate the convergence rate of multigrid
c     iteration.  let r(n) be the residual and e(n) be the error after
c     executing n cycles.  they are related by the residual equation
c
c          l * e(n) = r(n).
c
c     it follows that the ratio
c
c          || r(n+1) || / || r(n) ||
c
c     estimates
c
c          || e(n+1) || / || e(n) ||
c
c     which in turn estimates the convergence rate
c
c          c = max || e(k+1) || / || e(k) ||.
c               k
c
c     notice
c                         n
c          || e(n) || <  c  || e(0) ||.
c
c
c ... assumptions (see cud3sp.d)
c
c     (1) nx,ny,nz have the same values as iparm(14),iparm(15),iparm(16)
c         (used to set the fine grid resolution when calling cud3sp)
c
c     (2) nxa,nxb,nyc,nyd,nze,nzf have the same values as iparm(2),
c         iparm(3),iparm(4),iparm(5),iparm(6),iparm(7) (used to flag
c         boundary conditions when calling cud3sp).
c
c     (3) work,phi are the same parameters used in calling cud3sp.
c
c     (4) work,phi have not changed since the last call to cud3sp.
c
c     (3) assures a copy of the last approximation phi is contained in work.
c     if (1)-(4) are not true then resc3sp cannot compute the residual.
c
      subroutine resc3sp(nx,ny,nz,nxa,nxb,nyc,nyd,nze,nzf,wk,res)
      implicit none
      integer nx,ny,nz,nxa,nxb,nyc,nyd,nze,nzf,ir,ix,iy,iz
      complex wk(*),res(*)
c
c     set pointers
c
      ir = 1+(nx+2)*(ny+2)*(nz+2)
      ix = ir+nx*ny*nz
      iy = ix+3*nx
      iz = iy+3*ny
      call rec3sp(nx,ny,nz,nxa,nxb,nyc,nyd,nze,nzf,wk,wk(ir),wk(ix),
     +            wk(iy),wk(iz),res)
      return
      end

      subroutine rec3sp(nx,ny,nz,nxa,nxb,nyc,nyd,nze,nzf,phi,
     +                  rhs,cofx,cofy,cofz,resf)
      implicit none
      integer nx,ny,nz,nxa,nxb,nyc,nyd,nze,nzf
      integer i,j,k,ist,ifn,jst,jfn,kst,kfn
      complex cofx(nx,3),cofy(ny,3),cofz(nz,3)
      complex rhs(nx,ny,nz),phi(0:nx+1,0:ny+1,0:nz+1),resf(nx,ny,nz)
c
c     intialize residual to zero and set loop limits
c
      do k=1,nz
	do j=1,ny
	  do i=1,nx
	    resf(i,j,k) = (0.0,0.0)
	  end do
	end do
      end do
      ist = 1
      if (nxa.eq.1) ist = 2
      ifn = nx
      if (nxb.eq.1) ifn = nx-1
      jst = 1
      if (nyc.eq.1) jst = 2
      jfn = ny
      if (nyd.eq.1) jfn = ny-1
      kst = 1
      if (nze.eq.1) kst = 2
      kfn = nz
      if (nzf.eq.1) kfn = nz-1
c
c     compute residual
c
      do k=kst,kfn
	do j=jst,jfn
	  do i=ist,ifn
	    resf(i,j,k) =  rhs(i,j,k)-(
     +      cofx(i,1)*phi(i-1,j,k)+cofx(i,2)*phi(i+1,j,k) +
     +      cofy(j,1)*phi(i,j-1,k)+cofy(j,2)*phi(i,j+1,k) +
     +      cofz(k,1)*phi(i,j,k-1)+cofz(k,2)*phi(i,j,k+1) +
     +      (cofx(i,3)+cofy(j,3)+cofz(k,3))*phi(i,j,k)  )
	  end do
	end do
      end do
      return
      end