      SUBROUTINE stream_func_coeffs(depth,hoverd,case,height,currnt,
     $     value,n,nstep,num,cosa,sina,coeff,sol,rhs1,rhs2,a,b,ipvt,z,y)
C-----------------------------------------------------------------------
C
C     Calculation of steady waves
C
C-----------------------------------------------------------------------

      IMPLICIT none
C Arguements
      CHARACTER*10 DEPTH,CASE,CURRNT
      integer  n, nstep, num
      integer IPVT(num)
      real*8  HOVERD,HEIGHT,VALUE
      real*8  Z(num),COSA(0:num),SINA(0:num),COEFF(num),SOL(num,2),
     $     Y(num),RHS1(num),RHS2(num),A(num,num),B(num)

      integer  j, iter, i, ns, m, info, number
      real*8  PI, h, criter, crit, dho, dhe, sum

C.....Input data-----
C
C     "depth" IS EITHER 'deep' OR 'finite'
C     "hoverd" IS WAVE HEIGHT/DEPTH
C
C     "case" IS EITHER 'period' OR 'wavelength'
C     "height" IS HEIGHT/LENGTH IF "case" IS 'wavelength'
C     "height" IS HEIGHT/(g*T**2) IF "case" IS 'period'
C
C     "currnt" IS EITHER 'Euler' OR 'Stokes'
C     "value" is the magnitude of the mean Eulerian or Stokes velocities
C             non-dimensionalized with respect to wave height
C
C
C     "n" is the number of terms in the Fourier series and the number
C         of intervals in half a wavelength
C     "nstep" is the number of steps in wave height
C
C     "number" is the number of iterations for each height step
C
      NUMBER=256
C
C     "crit" is the criterion for convergence. If the sum of magnitudes
C            of corrections is smaller than crit, the iteration stops
C
      CRIT=1.D-6 !Originally 10^-4 GD
!      WRITE(6,20) DEPTH,HOVERD
!      WRITE(6,21) HEIGHT,CASE
!      WRITE(6,22) CURRNT,VALUE
!      WRITE(7,20) DEPTH,HOVERD
!      WRITE(7,21) HEIGHT,CASE
!      WRITE(7,22) CURRNT,VALUE
      PI=4.D0*DATAN(1.D0)
      DHE=HEIGHT/NSTEP
      DHO=HOVERD/NSTEP
C
C.....Commence stepping through steps in wave height
C
      DO 1 NS=1,NSTEP
         HEIGHT=NS*DHE
         HOVERD=NS*DHO
C
C.....Calculate initial linear solution
C
         IF(NS.LE.1) THEN
            CALL INIT(N,NUM,PI,HOVERD,HEIGHT,VALUE,DEPTH,CASE,CURRNT,
     $           Z,COSA,SINA,COEFF,SOL,Y)
         ELSE
C
C.....or extrapolate for next wave height, is neccessary
C
            DO 3 I=1,NUM
    3          Z(I)=2.D0*SOL(I,2)-SOL(I,1)
         ENDIF
C
C.....Commence iterative solution
C
         DO 4 ITER=1,NUMBER
C
C.....Calculate right sides of equations and differentiate numerically
C.....to obtain Jacobian matrix
C
            CALL EQNS(N,NUM,PI,HOVERD,HEIGHT,VALUE,DEPTH,CASE,CURRNT,
     $           Z,COSA,SINA,COEFF,SOL,Y,RHS1)
            DO 5 I=1,NUM
               H=0.01D0*Z(I)
               IF(DABS(Z(I)).LT.1.D-4) H=1.D-5
               Z(I)=Z(I)+H
               CALL EQNS(N,NUM,PI,HOVERD,HEIGHT,VALUE,DEPTH,CASE,CURRNT,
     $           Z,COSA,SINA,COEFF,SOL,Y,RHS2)
               Z(I)=Z(I)-H
               B(I)=-RHS1(I)
               DO 6 J=1,NUM
    6             A(J,I)=(RHS2(J)-RHS1(J))/H
    5       CONTINUE
C
C.....Solve matrix equation and correct variables, using LINPACK
C
C            CALL DGEFA(A,NUM,NUM,IPVT,INFO)
C            IF (INFO.NE.0) THEN
C               WRITE(6,27)
C               WRITE(7,27)
C               STOP
C            ENDIF
C            CALL DGESL(A,NUM,NUM,IPVT,B,0)
C.....Employ LAPACK instead... APEK 17-01-2009.
             CALL DGESV(NUM,1,A,NUM,IPVT,B,NUM,INFO)
C
C.....The b(i) are now corrections to each variable
C
            SUM=0.D0
            DO 7 I=1,NUM
               SUM=SUM+DABS(B(I))
    7          Z(I)=Z(I)+B(I)
            CRITER=CRIT
            IF(NS.EQ.NSTEP) CRITER=0.01D0*CRIT
            IF(SUM.LT.CRITER) GOTO 8
    4    CONTINUE
         WRITE(6,26) NUMBER
!         WRITE(7,26) NUMBER
         STOP
    8    IF(NS.EQ.1) THEN
            DO 9 I=1,NUM
    9          SOL(I,2)=Z(I)
         ELSE
            DO 10 I=1,NUM
               SOL(I,1)=SOL(I,2)
   10          SOL(I,2)=Z(I)
         ENDIF
    1 CONTINUE
C
C.....Calculate Fourier coefficients of surface elevation
C
      DO  J=1,N
         SUM=0.5D0*(Z(10)+Z(N+10)*(-1.D0)**J)
         DO  M=1,N-1
            SUM=SUM+Z(10+M)*COSA(MOD(M*J,N+N))
         END DO
         Y(J)=2.D0*SUM/N
      END DO

   20 FORMAT(//,'   Depth: ',A6,', Height/Depth',F7.4)
   21 FORMAT(/,'   Wave height',F9.6,', dimensionless with respect to ',
     .         A10)
   22 FORMAT(/,'   Current criterion ',A6,', Magnitude ', F5.2)
   23 FORMAT(//,'   Height step ',I2,' of ',I2)
   24 FORMAT(//,'   Iteration ',I3)
   25 FORMAT(//,'   Solution vector',10(/,6E13.6))
   26 FORMAT(/,' did not converge sufficiently after ',I3,' iterations')
   27 FORMAT(/,'   MATRIX SINGULAR')
      RETURN
      END


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by ucar                 .
c  .                                                             .
c  .       university corporation for atmospheric research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         spherepack3.0                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file gaqd.f
c
c     this file includes documentation and code for subrooutine gaqd.
c
c ... required files
c
c     none
c
c     subroutine gaqd(nlat,theta,wts,dwork,ldwork,ierror)
c
c     subroutine gaqd computes the nlat gaussian colatitudes and weights
c     in double precision. the colatitudes are in radians and lie in the
c     in the interval (0,pi).
c
c     input parameters
c
c     nlat    the number of gaussian colatitudes in the interval (0,pi)
c             (between the two poles).  nlat must be greater than zero.
c
c     dwork   a temporary work space
c
c     ldwork  the length of the work space  in the routine calling gaqd
c             ldwork must be at least nlat*(nlat+2).
c
c     output parameters
c
c     theta   a double precision vector of length nlat containing the
c             nlat gaussian colatitudes on the sphere in increasing radians
c             in the interval (o,pi).
c
c     wts     a double precision vector of length nlat containing the
c             nlat gaussian weights.
c
c     ierror = 0 no errors
c            = 1 if ldwork.lt.nlat*(nlat+2)
c            = 2 if nlat.le.0
c            = 3 if unable to compute gaussian points
c                (failure in in eigenvalue routine)
c
c  *****************************************************************
      subroutine gaqd(nlat,theta,wts,dwork,ldwork,ierror)
      double precision theta(nlat),wts(nlat),dwork(ldwork),x
      n = nlat
      ierror = 1
c     check work space length
      if (ldwork .lt. n*(n+2)) return
      ierror = 2
      if (n.le.0) return
      ierror = 0
      if (n.gt.2) then
c
c     partition dwork space for double precision eigenvalue(vector computation)
c
      i1 = 1
      i2 = i1+n
      i3 = i2+n
      call gaqd1(n,theta,wts,dwork(i1),dwork(i2),dwork(i3),ierror)
      if (ierror.ne.0) then
      ierror = 3
      return
      end if
      return
      else if (n.eq.1) then
      wts(1) = 2.0d0
      theta(1) = dacos(0.0d0)
      else if (n.eq.2) then
c     compute weights and points analytically when n=2
      wts(1) = 1.0d0
      wts(2) = 1.0d0
      x = dsqrt(1.0d0/3.0d0)
      theta(1) = dacos(x)
      theta(2) = dacos(-x)
      return
      end if
      end
      subroutine gaqd1(n,theta,wts,w,e,z,ier)
      dimension theta(n),wts(n),w(n),e(n),z(n,n)
      double precision theta,wts,temp,w,e,z
c     set symmetric tridiagnonal matrix subdiagonal and diagonal
c     coefficients for matrix coming from coefficients in the
c     recursion formula for legendre polynomials
c     a(n)*p(n-1)+b(n)*p(n)+c(n)*p(n+1) = 0.
      w(1)=0.d0
      e(1) = 0.d0
      do 100 j=2,n
      e(j)= (j-1.d0)/dsqrt((2.d0*j-1.d0)*(2.d0*j-3.d0))
      w(j) = 0.d0
  100 continue
c
c     compute eigenvalues and eigenvectors
c
      matz = 1
      call drst(n,n,w,e,matz,z,ier)
      if (ier.ne.0) return
c
c     compute gaussian weights and points
c
      do 101 j=1,n
      theta(j) = dacos(w(j))
c
c     set gaussian weights as 1st components of eigenvectors squared
c
      wts(j) = 2.0d0*z(1,j)**2
  101 continue
c
c     reverse order of gaussian points to be
c     monotonic increasing in radians
c
      n2 = n/2
      do 102 i=1,n2
      temp = theta(i)
      theta(i) = theta(n-i+1)
      theta(n-i+1) = temp
  102 continue
      return
      end
      subroutine drst(nm,n,w,e,matz,z,ierr)
c     drst is a double precision modification of rst off eispack
c     to be used  to compute gaussian points and weights

c
      integer i,j,n,nm,ierr,matz
      double precision w(n),e(n),z(nm,n)

c
c     .......... find both eigenvalues and eigenvectors ..........
   20 do 40 i = 1, n
c
	 do 30 j = 1, n
	    z(j,i) = 0.0d0
   30    continue
c
	 z(i,i) = 1.0d0
   40 continue
c
      call  dintql(nm,n,w,e,z,ierr)
      return
      end
      subroutine dintql(nm,n,d,e,z,ierr)
c     dintql is a double precision modification of intql2 off
c     eispack to be used by gaqd in spherepack for computing
c     gaussian weights and points
c
      integer i,j,k,l,m,n,ii,nm,mml,ierr
      double precision d(n),e(n),z(nm,n)
      double precision b,c,f,g,p,r,s,tst1,tst2,dpytha
      ierr = 0
      if (n .eq. 1) go to 1001
c
      do 100 i = 2, n
  100 e(i-1) = e(i)
c
      e(n) = 0.0d0
c
      do 240 l = 1, n
	 j = 0
c     .......... look for small sub-diagonal element ..........
c
  105    nm1 = n-1
         if(l .gt. nm1) go to 111
         do 110 mdo = l, nm1
            m = mdo
	    tst1 = dabs(d(m)) + dabs(d(m+1))
	    tst2 = tst1 + dabs(e(m))
	    if (tst2 .eq. tst1) go to 120
  110    continue
  111    m = n
c
  120    p = d(l)
	 if (m .eq. l) go to 240
	 if (j .eq. 30) go to 1000
	 j = j + 1
c     .......... form shift ..........
	 g = (d(l+1) - p) / (2.0d0 * e(l))
	 r = dpytha(g,1.0d0)
	 g = d(m) - p + e(l) / (g + sign(r,g))
	 s = 1.0d0
	 c = 1.0d0
	 p = 0.0d0
	 mml = m - l
c     .......... for i=m-1 step -1 until l do -- ..........
	 do 200 ii = 1, mml
	    i = m - ii
	    f = s * e(i)
	    b = c * e(i)
	    r = dpytha(f,g)
	    e(i+1) = r
	    if (r .eq. 0.0d0) go to 210
	    s = f / r
	    c = g / r
	    g = d(i+1) - p
	    r = (d(i) - g) * s + 2.0d0 * c * b
	    p = s * r
	    d(i+1) = g + p
	    g = c * r - b
c     .......... form vector ..........
	    do 180 k = 1, n
	       f = z(k,i+1)
	       z(k,i+1) = s * z(k,i) + c * f
	       z(k,i) = c * z(k,i) - s * f
  180       continue
c
  200    continue
c
	 d(l) = d(l) - p
	 e(l) = g
	 e(m) = 0.0d0
	 go to 105
c     .......... recover from underflow ..........
  210    d(i+1) = d(i+1) - p
	 e(m) = 0.0d0
	 go to 105
  240 continue
c     .......... order eigenvalues and eigenvectors ..........
      do 300 ii = 2, n
	 i = ii - 1
	 k = i
	 p = d(i)
c
	 do 260 j = ii, n
	    if (d(j) .ge. p) go to 260
	    k = j
	    p = d(j)
  260    continue
c
	 if (k .eq. i) go to 300
	 d(k) = d(i)
	 d(i) = p
c
	 do 280 j = 1, n
	    p = z(j,i)
	    z(j,i) = z(j,k)
	    z(j,k) = p
  280    continue
c
  300 continue
c
      go to 1001
c     .......... set error -- no convergence to an
c                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end
      double precision function dpytha(a,b)
      double precision a,b
c     dpytha is a double precision modification of pythag off eispack
c     for use by dimtql

c
c     finds sqrt(a**2+b**2) without overflow or destructive underflow
c
      double precision p,r,s,t,u
      p = dabs(a)
      if (dabs(b).ge.dabs(a)) p = dabs(b)
      if (p .eq. 0.0d0) go to 20
      r = (dabs(a)/p)**2
      if (dabs(b).lt.dabs(a)) r = (dabs(b)/p)**2
   10 continue
	 t = 4.0d0 + r
	 if (t .eq. 4.0d0) go to 20
	 s = r/t
	 u = 1.0d0 + 2.0d0*s
	 p = u*p
	 r = (s/u)**2 * r
      go to 10
   20 dpytha = p
      return
      end


== Mathematical constants
PI  << 3.141 592 653 59
E   << 2.718 281 828 46
PHI << 1.618 033 988 75
SQ2 << 1.414 213 562 37

π << PI
φ << PHI

== Physical constants
PLANCK        CONSTANT << 6.626 070 04e-34
GRAVITATIONAL CONSTANT << 6.674 08e-10


C++***************************************************************
C Subroutine to compute some statistical parameters
C of an image, to be used as scaling values for further display
C
C JLP
C Version of 18-03-90
C--***************************************************************
	SUBROUTINE JLP_AUTO_SCALE(IMAGE,NX,NY,IDIM,MIN1,MAX1,
	1	MEAN1,MEAN2,SIGMA1,SIGMA2,IXMI,IYMI,IXMA,IYMA)
	INTEGER*4 NX,NY,IDIM
	INTEGER*4 IXMI,IYMI,IXMA,IYMA
	REAL*4 IMAGE(IDIM,*)
	REAL*4 MEAN1,SIGMA1,MEAN2,SIGMA2,MIN1,MAX1
	REAL*4 XLOW,XHIGH,XNN
	REAL*8 SUM,SUMSQ

C debug:
C        PRINT *,' image(1,1) =',image(1,1)

C First iteration:
	MIN1=IMAGE(1,1)
	MAX1=IMAGE(1,1)
	IXMI=1
	IYMI=1
	IXMA=1
	IYMA=1
	SUM=0.
	SUMSQ=0.

	DO IY=1,NY
	  DO IX=1,NX
	    WORK=IMAGE(IX,IY)
	    IF(WORK.LT.MIN1)THEN
	      IXMI=IX
	      IYMI=IY
	      MIN1=WORK
	    ENDIF
	    IF(WORK.GT.MAX1)THEN
	      IXMA=IX
	      IYMA=IY
	      MAX1=WORK
	    ENDIF
	    SUM=SUM+WORK
	    SUMSQ=SUMSQ+WORK*WORK
	  END DO
	END DO
	MEAN1=SUM/(NX*NY)
	SIGMA1=SQRT(SUMSQ/(NX*NY)-MEAN1**2)

C Second iteration:
	SUM=0.
	SUMSQ=0.
	XLOW=MEAN1-3*SIGMA1
	XHIGH=MEAN1+3*SIGMA1
	XNN=0.

	DO IY=1,NY
	  DO IX=1,NX
	    WORK=IMAGE(IX,IY)
	    IF((WORK.LE.XHIGH).AND.(WORK.GE.XLOW))THEN
	      SUM=SUM+WORK
	      SUMSQ=SUMSQ+WORK*WORK
	      XNN=XNN+1.
	    ENDIF
	  END DO
	END DO

	IF(XNN.NE.0)THEN
	  MEAN2=SUM/XNN
	  SIGMA2=SQRT(SUMSQ/XNN-MEAN2**2)
	ELSE
	  PRINT *,' No points between Mean1 +/- 3*Sigma1 !!!!'
	  MEAN2=MEAN1
	  SIGMA2=SIGMA1
	ENDIF

	RETURN
	END


c
c ------------------------------------------------------------
c
       subroutine computeCubicShifts(shiftxxx,shiftxxy,
     &                   shiftxyy,shiftyyy,hx,hy,kirr)

       use amr_module

       implicit none
       include "quadrature.i"

       double precision shiftxxx,shiftxxy
       double precision shiftxyy,shiftyyy
       double precision x0,y0,arr,artri
       double precision x1,y1,x2,y2,x3,y3
       double precision xval,yval,hx,hy
       double precision triangle_area
       integer idx1,idx2,idx3,ivert,it,itq,itri
       integer kirr

c      compute integrals of cubics over irreular cells
c      (if kirr is regular then integrals are zero and this
c       routine not called).

       shiftxxx = 0.d0
       shiftxxy = 0.d0
       shiftxyy = 0.d0
       shiftyyy = 0.d0

       x0 = xcirr(kirr)
       y0 = xcirr(kirr)
       arr = ar(kirr)

       ivert = 1
       do while (poly(ivert+1,1,kirr) .ne. -11)
          ivert = ivert + 1
       end do

       itri = ivert - 3
       idx1 = 1
       x1 = poly(idx1,1,kirr)
       y1 = poly(idx1,2,kirr)

       do it = 1, itri
          idx2 = it + 1
          idx3 = it + 3
          x2 = poly(idx2,1,kirr)
          y2 = poly(idx2,2,kirr)
          x3 = poly(idx3,1,kirr)
          y3 = poly(idx3,2,kirr)
          artri = triangle_area(x1,x2,x3,y1,y2,y3)

          do  itq = 1, ntriquad
            xval = x1 * rtri(itq) + x2 * stri(itq)
     &          +  x3 * (1.d0-rtri(itq)-stri(itq))
            yval = y1 * rtri(itq) + y2 * stri(itq)
     &          +  y3 * (1.d0-rtri(itq)-stri(itq))

            shiftxxx = shiftxxx + (artri/arr)*wtri(itq) *
     &                            (xval-x0)**3 / (hx**3)
             shiftxxy = shiftxxy + (artri/arr)*wtri(itq) *
     &                            (yval-y0)*(xval-x0)**2 / (hy*hx**2)
             shiftxyy = shiftxyy + (artri/arr)*wtri(itq) *
     &                            (xval-x0)*(yval-y0)**2 / (hx*hy**2)
             shiftyyy =shiftyyy + (artri/arr)*wtri(itq) *
     &                           (yval-y0)**3 / (hy**3)
          end do  ! end loop over quadrature points
       end do ! end loop over each triangle in polygon

       return
       end


      real*4 function compress (x)

      implicit real*8 (a-h,o-z)
      real*8 x, log2, mant
      integer ndig

      ndig = 10

      if (x.eq.0.0) then
         compress = real(x)
         return
      endif

c     exponent part
      log2 = int((log(abs(x))/0.69314718056)+0.5)

c     mantissa, truncated
      mant = dble(nint(x/(2.0**(log2-ndig))))/(2.0**ndig)

c     multiply 2^exponent back in
      compress = real(mant*(2.0**log2))

      return
      end


MODULE nr
       INTERFACE pythag
          FUNCTION pythag_dp(a,b)
          USE nrtype
          REAL(DP), INTENT(IN) :: a,b
          REAL(DP) :: pythag_dp
          END FUNCTION pythag_dp
!BL
          FUNCTION pythag_sp(a,b)
          USE nrtype
          REAL(SP), INTENT(IN) :: a,b
          REAL(SP) :: pythag_sp
          END FUNCTION pythag_sp
       END INTERFACE
       INTERFACE svbksb
          SUBROUTINE svbksb_dp(u,w,v,b,x)
          USE nrtype
          REAL(DP), DIMENSION(:,:), INTENT(IN) :: u,v
          REAL(DP), DIMENSION(:), INTENT(IN) :: w,b
          REAL(DP), DIMENSION(:), INTENT(OUT) :: x
          END SUBROUTINE svbksb_dp
!BL
          SUBROUTINE svbksb_sp(u,w,v,b,x)
          USE nrtype
          REAL(SP), DIMENSION(:,:), INTENT(IN) :: u,v
          REAL(SP), DIMENSION(:), INTENT(IN) :: w,b
          REAL(SP), DIMENSION(:), INTENT(OUT) :: x
          END SUBROUTINE svbksb_sp
       END INTERFACE
       INTERFACE svdcmp
          SUBROUTINE svdcmp_dp(a,w,v)
          USE nrtype
          REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: a
          REAL(DP), DIMENSION(:), INTENT(OUT) :: w
          REAL(DP), DIMENSION(:,:), INTENT(OUT) :: v
          END SUBROUTINE svdcmp_dp
!BL
          SUBROUTINE svdcmp_sp(a,w,v)
          USE nrtype
          REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
          REAL(SP), DIMENSION(:), INTENT(OUT) :: w
          REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v
          END SUBROUTINE svdcmp_sp
       END INTERFACE
        INTERFACE
                FUNCTION convlv(data,respns,isign)
                USE nrtype
                REAL(SP), DIMENSION(:), INTENT(IN) :: data
                REAL(SP), DIMENSION(:), INTENT(IN) :: respns
                INTEGER(I4B), INTENT(IN) :: isign
                REAL(SP), DIMENSION(size(data)) :: convlv
                END FUNCTION convlv
        END INTERFACE
        INTERFACE realft
                SUBROUTINE realft_dp(data,isign,zdata)
                USE nrtype
                REAL(DP), DIMENSION(:), INTENT(INOUT) :: data
                INTEGER(I4B), INTENT(IN) :: isign
                COMPLEX(DPC), DIMENSION(:), OPTIONAL, TARGET :: zdata
                END SUBROUTINE realft_dp
!BL
                SUBROUTINE realft_sp(data,isign,zdata)
                USE nrtype
                REAL(SP), DIMENSION(:), INTENT(INOUT) :: data
                INTEGER(I4B), INTENT(IN) :: isign
                COMPLEX(SPC), DIMENSION(:), OPTIONAL, TARGET :: zdata
                END SUBROUTINE realft_sp
        END INTERFACE
        INTERFACE four1
                SUBROUTINE four1_dp(data,isign)
                USE nrtype
                COMPLEX(DPC), DIMENSION(:), INTENT(INOUT) :: data
                INTEGER(I4B), INTENT(IN) :: isign
                END SUBROUTINE four1_dp
!BL
                SUBROUTINE four1_sp(data,isign)
                USE nrtype
                COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data
                INTEGER(I4B), INTENT(IN) :: isign
                END SUBROUTINE four1_sp
        END INTERFACE
        INTERFACE fourrow
                SUBROUTINE fourrow_dp(data,isign)
                USE nrtype
                COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: data
                INTEGER(I4B), INTENT(IN) :: isign
                END SUBROUTINE fourrow_dp
!BL
                SUBROUTINE fourrow_sp(data,isign)
                USE nrtype
                COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
                INTEGER(I4B), INTENT(IN) :: isign
                END SUBROUTINE fourrow_sp
        END INTERFACE
END MODULE nr


program maxmin
!! Fortran standard does NOT specify how to handle NaN vis-a-vis max and min
!! https://gcc.gnu.org/onlinedocs/gfortran/MAX-and-MIN-intrinsics-with-REAL-NaN-arguments.html

use, intrinsic :: ieee_arithmetic
use, intrinsic :: iso_fortran_env, stderr=>error_unit
implicit none (type, external)

real :: A(4), x, y, nan, inf

nan = ieee_value(0., ieee_quiet_nan)
inf = ieee_value(0., ieee_positive_inf)

! PGI 19.10 says 0 instad of NaN here
if(.not.ieee_is_nan(nan)) then
  write(stderr,*) 'NaN: ',nan
endif

A = [0., 1., 2., nan]
print '(4F10.7,A,F10.7)', A, ' maximum is', maxval(A)

x = nan
y = 1.

print '(F10.7,F10.7,A,F10.7)', x,y, ' maximum is ',max(x,y)

! Gfortran, Flang 7 say inf; PGI, Intel say NaN
print *,'max of inf() and NaN is', max(inf, nan)

end program


module gauss_and_legendre_mod

use       fms_mod, only: mpp_pe, mpp_root_pe, error_mesg, FATAL, &
                         write_version_number

use constants_mod, only: pi

!-----------------------------------------------------------------------
!   computes Gaussian latitudes and associated Legendre polynomials
!
!-----------------------------------------------------------------------

implicit none
private

character(len=128), parameter :: version = '$Id: gauss_and_legendre.f90,v 10.0 2003/10/24 22:01:02 fms Exp $'
character(len=128), parameter :: tagname ='$Name: latest $'

logical :: entry_to_logfile_done=.false.

public :: compute_legendre, compute_gaussian

contains

!-----------------------------------------------------------------------
subroutine compute_legendre(legendre, num_fourier, fourier_inc,  &
                num_spherical, sin_lat, n_lat)
!-----------------------------------------------------------------------

integer, intent (in) :: num_fourier, fourier_inc, num_spherical, n_lat
real,    intent (in), dimension(n_lat) :: sin_lat

real, intent (out), dimension(0:num_fourier, 0:num_spherical, n_lat)  :: legendre

integer :: j, m, n , fourier_max
real, dimension(0:num_fourier*fourier_inc, 0:num_spherical) :: poly, eps, m2, l2
real, dimension(0:num_fourier*fourier_inc) :: b
real, dimension(n_lat) :: cos_lat

if(.not.entry_to_logfile_done) then
  call write_version_number(version, tagname)
  entry_to_logfile_done=.true.
endif

fourier_max = num_fourier*fourier_inc

do j=1,n_lat
  cos_lat(j)=sqrt(1-sin_lat(j)*sin_lat(j))
end do

do n=0,num_spherical
  do m=0,fourier_max
    m2(m,n)   = m**2
    l2(m,n)   = (m+n)**2
  end do
end do

eps= sqrt((l2 -m2)/(4.0*l2 - 1.0))

do m=1,fourier_max
  b(m) = SQRT(0.5*(2.0*float(m) + 1.0)/float(m))
end do

poly(0,0) = sqrt(0.5)
do j=1,n_lat
  do m=1,fourier_max
    poly(m,0) = b(m)*cos_lat(j)*poly(m-1,0)
  end do
  do m=0,fourier_max
     poly(m,1) =  sin_lat(j)*poly(m,0)/eps(m,1)
  end do

  do n=2,num_spherical
    do m=0,fourier_max
      poly(m,n) = (sin_lat(j)*poly(m,n-1) - eps(m,n-1)*poly(m,n-2))/eps(m,n)
    end do
  end do

  do n = 0, num_spherical
    do m = 0,num_fourier
      legendre(m,n,j) = poly(m*fourier_inc,n)
    end do
  end do
end do

return
end subroutine compute_legendre

!----------------------------------------------------------------------
subroutine compute_gaussian(sin_hem, wts_hem, n_hem)
!----------------------------------------------------------------------
!
!     reference:
!       press, h. william, et. al., numerical recipes (fortran version),
!       cambridge, england: cambridge university press (1990)
!
!------------------------------------------------------------------------

integer, intent (in) :: n_hem
real, intent (out), dimension(n_hem) :: sin_hem, wts_hem

real :: converg
integer :: itermax
integer :: i, iter, j, n, nprec
real :: pp, p1, p2, p3, z, z1

if(.not.entry_to_logfile_done) then
  call write_version_number(version, tagname)
  entry_to_logfile_done=.true.
endif

! must use a more relaxed convergence criteria on the
! workstations than that for the cray T90
! fez code is commented out

!if(kind(converg).eq.8) then
!  converg = 1.0E-15
!else if(kind(converg).eq.4) then
!  converg = 1.0E-7
!else
!  call error_mesg('compute_gaussian','dont know what value to use for converg', FATAL)
!end if

! The 2 lines of code below will yeild a different result than the fez code
! when kind(converg)=4. converg is 1.0E-6 instead of 1.0E-7
! This should be investigated further, but it's OK for now because it yeilds
! the same result on the HPCS. -- pjp
nprec = precision(converg)
converg = .1**nprec

itermax = 10

n=2*n_hem
do i=1,n_hem
  z = cos(pi*(i - 0.25)/(n + 0.5))
  do iter=1,itermax
     p1 = 1.0
     p2 = 0.0

     do j=1,n
        p3 = p2
        p2 = p1
        p1 = ((2.0*j - 1.0)*z*p2 - (j - 1.0)*p3)/j
     end do

     pp = n*(z*p1 - p2)/(z*z - 1.0E+00)
     z1 = z
     z  = z1 - p1/pp
     if(ABS(z - z1) .LT. converg) go to 10
  end do
  call error_mesg('compute_gaussian','abscissas failed to converge in itermax iterations', FATAL)

  10  continue

  sin_hem (i)     = z
  wts_hem (i)     = 2.0/((1.0 - z*z)*pp*pp)

end do

return
end subroutine compute_gaussian
!----------------------------------------------------------------------

end module gauss_and_legendre_mod


!==========================================
! particle1d.f90
! Author: Devansh Shukla
!------------------------------------------
program particle_1D
    ! Program to compute motion of a particle trapped in a one dimension box.

    implicit none
    real*8 :: x0=0.0, t0=0.0, tf=0.0, dt=0.0, t=0.0
    real*8 :: x=0.0, vx=0.0, l0=0.0, l1=0.0
    character(len=*), parameter :: fmt1 = "(F10.4, x, F10.4, x, F10.4)"

    open(unit=8, file="Particle1D.dat")

    print *, "---------------------------------------"
    print *, "Enter initial position x0"
    read *, x0

    print *, "Enter velocity vx"
    read *, vx

    print *, "Enter bounds l0, l1"
    read *, l0, l1

    print *, "Enter t0, tf, dt"
    read *, t0, tf, dt
    print *, "---------------------------------------"

    print "(x,A,F10.4)", "x0=", x0
    print "(x,A,F10.4,F10.4)", "l0, l1=", l0, l1
    print "(x,A,F10.4,F10.4,F10.4)", "t0, tf, dt=", t0, tf, dt
    print *, "---------------------------------------"

    print "(A10,A10,A10)", "time", "x(t)", "vx"

    ! Formatting l0, l1 to our standards for fortran floating point arithmatic
    l0 = l0
    l1 = l1 - dt
    t = t0
    x = x0
    do while (t .le. tf)
        write (*, fmt1) t, x, vx
        write (8, fmt1) t, x, vx
        x = x + vx * dt
        t = t + dt
        if (x .lt. l0 .or. x .gt. l1) vx = -vx
    enddo
    print *, "---------------------------------------"
    close(8)
end program particle_1D


MODULE complex_class
IMPLICIT NONE

! Type definition
TYPE,PUBLIC :: complex_ob   ! This will be the name we instantiate
   !PRIVATE
   REAL :: re               ! Real part
   REAL :: im               ! Imaginary part
CONTAINS
   PRIVATE
   PROCEDURE :: ac => add_complex_to_complex
   PROCEDURE :: ar => add_real_to_complex
   GENERIC, PUBLIC :: add => ac, ar
   PROCEDURE, PUBLIC :: ini
END TYPE complex_ob

! Declare access for methods
PRIVATE :: add_complex_to_complex, add_real_to_complex

! Now add methods
CONTAINS

   ! Method to initialise complex number
   SUBROUTINE ini(this, re, im)
   CLASS(complex_ob),INTENT(OUT) :: this
   REAL,INTENT(IN) :: re,im
   this%re = re
   this%im = im
   END SUBROUTINE ini

   ! Insert method add_complex_to_complex here:
   SUBROUTINE add_complex_to_complex( this, c2 )
   CLASS(complex_ob) :: this
   CLASS(complex_ob),INTENT(IN) :: c2
   this%re = this%re + c2%re
   this%im = this%im + c2%im
   END SUBROUTINE add_complex_to_complex

   ! Insert method add_real_to_complex here:
   SUBROUTINE add_real_to_complex( this, a )
   CLASS(complex_ob) :: this
   REAL,INTENT(IN) :: a
   this%re = this%re + a
   END SUBROUTINE add_real_to_complex

END MODULE complex_class


C File: arrays-sect-09.f
C Illustrates the use of array sections using implicit do loops to access both
C the source and destination of each assignment.

      program main
      implicit none

      integer, dimension (5) :: A
      integer, dimension(10) :: B
      integer :: i

      do i = 1, 5
          A(i) = 0
          B(i) = 11*i
          B(i+5) = 7*i+6
      end do

      write (*,10) A(1), A(2), A(3), A(4), A(5)

 10   format(5(I5,X))

C     Use of a more complex array section to redefine alternating elements of A
C     This example uses implicit do loops to access both the source and
C     destination elements.
      A(1:5:2) = B(2:8:3)

      write (*,10) A(1), A(2), A(3), A(4), A(5)

      stop
      end program main


! from http://calcul.math.cnrs.fr/Documents/Ecoles/2010/f2py-cours.pdf
! Pierre Navaro

! permet d'ecrire "c=norm(a)" avec un vecteur numpy
! - le fait d'avoir mis "intent(out)" definit la valeur retour (c)
! - f2py comprend que "n" est la taille de "a" et definit un arg optionnel
!   qui vaut par defaut "len(a)"
subroutine norme(a, c, n)
    integer :: n
    real(8), dimension(n), intent(in) :: a
    real(8), intent(out) :: c
    real(8) :: sommec
    integer :: i
    sommec = 0
    do i = 1, n
        sommec = sommec + a(i)*a(i)
    end do
    c = sqrt(sommec)
end subroutine norme