c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file vhsec.f
c
c     this file contains code and documentation for subroutines
c     vhsec and vhseci
c
c ... files which must be loaded with vhsec.f
c
c     sphcom.f, hrfft.f
c
c     subroutine vhsec(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
c    +                 mdab,ndab,wvhsec,lvhsec,work,lwork,ierror)
c
c     subroutine vhsec performs the vector spherical harmonic synthesis
c     of the arrays br, bi, cr, and ci and stores the result in the
c     arrays v and w. v(i,j) and w(i,j) are the colatitudinal
c     (measured from the north pole) and east longitudinal components
c     respectively, located at colatitude theta(i) = (i-1)*pi/(nlat-1)
c     and longitude phi(j) = (j-1)*2*pi/nlon. the spectral
c     representation of (v,w) is given below at output parameters v,w.
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (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 zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     ityp   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon.
c
c            = 1  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 2  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 3  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 5  v is symmetric and w is antisymmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 6  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 8  v is antisymmetric and w is symmetric about the
c                 equator. the synthesis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the synthesis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the synthesis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c
c     nt     the number of syntheses.  in the program that calls vhsec,
c            the arrays v,w,br,bi,cr, and ci can be three dimensional
c            in which case multiple syntheses will be performed.
c            the third index is the synthesis index which assumes the
c            values 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 all the arrays are two
c            dimensional.
c
c     idvw   the first dimension of the arrays v,w as it appears in
c            the program that calls vhsec. if ityp .le. 2 then idvw
c            must be at least nlat.  if ityp .gt. 2 and nlat is
c            even then idvw must be at least nlat/2. if ityp .gt. 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays v,w as it appears in
c            the program that calls vhsec. jdvw must be at least nlon.
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c     cr,ci  that contain the vector spherical harmonic coefficients
c            in the spectral representation of v(i,j) and w(i,j) given
c            below at the discription of output parameters v and w.
c
c     mdab   the first dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhsec. mdab must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhsec. ndab must be at
c            least nlat.
c
c     wvhsec an array which must be initialized by subroutine vhseci.
c            once initialized, wvhsec can be used repeatedly by vhsec
c            as long as nlon and nlat remain unchanged.  wvhsec must
c            not be altered between calls of vhsec.
c
c     lvhsec the dimension of the array wvhsec as it appears in the
c            program that calls vhsec. define
c
c               l1 = min0(nlat,nlon/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 lvhsec must be at least
c
c               4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vhsec. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if ityp .le. 2 then lwork must be at least
c
c                    nlat*(2*nt*nlon+max0(6*l2,nlon))
c
c            if ityp .gt. 2 then lwork must be at least
c
c                    l2*(2*nt*nlon+max0(6*nlat,nlon))
c
c     **************************************************************
c
c     output parameters
c
c     v,w    two or three dimensional arrays (see input parameter nt)
c            in which the synthesis is stored. v is the colatitudinal
c            component and w is the east longitudinal component.
c            v(i,j),w(i,j) contain the components at colatitude
c            theta(i) = (i-1)*pi/(nlat-1) and longitude phi(j) =
c            (j-1)*2*pi/nlon. the index ranges are defined above at
c            the input parameter ityp. v and w are computed from the
c            formulas given below
c
c
c     define
c
c     1.  theta is colatitude and phi is east longitude
c
c     2.  the normalized associated legendre funnctions
c
c         pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative
c                        of (x**2-1)**n with respect to x=cos(theta)
c
c     3.  vbar(m,n,theta) = the derivative of pbar(m,n,theta) with
c                           respect to theta divided by the square
c                           root of n(n+1).
c
c         vbar(m,n,theta) is more easily computed in the form
c
c         vbar(m,n,theta) = (sqrt((n+m)*(n-m+1))*pbar(m-1,n,theta)
c         -sqrt((n-m)*(n+m+1))*pbar(m+1,n,theta))/(2*sqrt(n*(n+1)))
c
c     4.  wbar(m,n,theta) = m/(sin(theta))*pbar(m,n,theta) divided
c                           by the square root of n(n+1).
c
c         wbar(m,n,theta) is more easily computed in the form
c
c         wbar(m,n,theta) = sqrt((2n+1)/(2n-1))*(sqrt((n+m)*(n+m-1))
c         *pbar(m-1,n-1,theta)+sqrt((n-m)*(n-m-1))*pbar(m+1,n-1,theta))
c         /(2*sqrt(n*(n+1)))
c
c
c    the colatitudnal dependence of the normalized surface vector
c                spherical harmonics are defined by
c
c     5.    bbar(m,n,theta) = (vbar(m,n,theta),i*wbar(m,n,theta))
c
c     6.    cbar(m,n,theta) = (i*wbar(m,n,theta),-vbar(m,n,theta))
c
c
c    the coordinate to index mappings
c
c     7.   theta(i) = (i-1)*pi/(nlat-1) and phi(j) = (j-1)*2*pi/nlon
c
c
c     the maximum (plus one) longitudinal wave number
c
c     8.     mmax = min0(nlat,nlon/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c    if we further define the output vector as
c
c     9.    h(i,j) = (v(i,j),w(i,j))
c
c    and the complex coefficients
c
c     10.   b(m,n) = cmplx(br(m+1,n+1),bi(m+1,n+1))
c
c     11.   c(m,n) = cmplx(cr(m+1,n+1),ci(m+1,n+1))
c
c
c    then for i=1,...,nlat and  j=1,...,nlon
c
c        the expansion for real h(i,j) takes the form
c
c     h(i,j) = the sum from n=1 to n=nlat-1 of the real part of
c
c         .5*(b(0,n)*bbar(0,n,theta(i))+c(0,n)*cbar(0,n,theta(i)))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c              b(m,n)*bbar(m,n,theta(i))*exp(i*m*phi(j))
c             +c(m,n)*cbar(m,n,theta(i))*exp(i*m*phi(j))
c
c   *************************************************************
c
c   in terms of real variables this expansion takes the form
c
c             for i=1,...,nlat and  j=1,...,nlon
c
c     v(i,j) = the sum from n=1 to n=nlat-1 of
c
c               .5*br(1,n+1)*vbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c       (br(m+1,n+1)*vbar(m,n,theta(i))-ci(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *cos(m*phi(j))
c      -(bi(m+1,n+1)*vbar(m,n,theta(i))+cr(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *sin(m*phi(j))
c
c    and for i=1,...,nlat and  j=1,...,nlon
c
c     w(i,j) = the sum from n=1 to n=nlat-1 of
c
c              -.5*cr(1,n+1)*vbar(0,n,theta(i))
c
c     plus the sum from m=1 to m=mmax-1 of the sum from n=m to
c     n=nlat-1 of the real part of
c
c      -(cr(m+1,n+1)*vbar(m,n,theta(i))+bi(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *cos(m*phi(j))
c      +(ci(m+1,n+1)*vbar(m,n,theta(i))-br(m+1,n+1)*wbar(m,n,theta(i)))
c                                          *sin(m*phi(j))
c
c
c      br(m+1,nlat),bi(m+1,nlat),cr(m+1,nlat), and ci(m+1,nlat) are
c      assumed zero for m even.
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 ityp
c            = 4  error in the specification of nt
c            = 5  error in the specification of idvw
c            = 6  error in the specification of jdvw
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lvhsec
c            = 10 error in the specification of lwork
c
c
c *******************************************************************
c
c     subroutine vhseci(nlat,nlon,wvhsec,lvhsec,dwork,ldwork,ierror)
c
c     subroutine vhseci initializes the array wvhsec which can then be
c     used repeatedly by subroutine vhsec until nlat or nlon is changed.
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (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 zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     lvhsec the dimension of the array wvhsec as it appears in the
c            program that calls vhsec. define
c
c               l1 = min0(nlat,nlon/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 lvhsec must be at least
c
c            4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15
c
c
C*PL*ERROR* Comment line too long
c     dwork  a double precision work array that does not have to be saved.
c
c     ldwork the dimension of the array dwork as it appears in the
c            program that calls vhsec. ldwork must be at least
c            2*(nlat+2)
c
c     **************************************************************
c
c     output parameters
c
c     wvhsec an array which is initialized for use by subroutine vhsec.
c            once initialized, wvhsec can be used repeatedly by vhsec
c            as long as nlat or nlon remain unchanged.  wvhsec must not
c            be altered between calls of vhsec.
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 lvhsec
c            = 4  error in the specification of ldwork
c
c
c
      SUBROUTINE DVHSEC(NLAT,NLON,ITYP,NT,V,W,IDVW,JDVW,BR,BI,CR,CI,
     +                  MDAB,NDAB,WVHSEC,LVHSEC,WORK,LWORK,IERROR)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION WVHSEC
      DOUBLE PRECISION WORK
c
      DIMENSION V(IDVW,JDVW,1),W(IDVW,JDVW,1),BR(MDAB,NDAB,1),
     +          BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),WORK(1),
     +          WVHSEC(1)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.1) RETURN
      IERROR = 3
      IF (ITYP.LT.0 .OR. ITYP.GT.8) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ITYP.LE.2.AND.IDVW.LT.NLAT) .OR.
     +    (ITYP.GT.2.AND.IDVW.LT.IMID)) RETURN
      IERROR = 6
      IF (JDVW.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IF (MDAB.LT.MMAX) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
      LZZ1 = 2*NLAT*IMID
      LABC = 3* (MAX0(MMAX-2,0)* (NLAT+NLAT-MMAX-1))/2
      IF (LVHSEC.LT.2* (LZZ1+LABC)+NLON+15) RETURN
      IERROR = 10
      IF (ITYP.LE.2 .AND. LWORK.LT.NLAT*
     +    (2*NT*NLON+MAX0(6*IMID,NLON))) RETURN
      IF (ITYP.GT.2 .AND. LWORK.LT.IMID*
     +    (2*NT*NLON+MAX0(6*NLAT,NLON))) RETURN
      IERROR = 0
      IDV = NLAT
      IF (ITYP.GT.2) IDV = IMID
      LNL = NT*IDV*NLON
      IST = 0
      IF (ITYP.LE.2) IST = IMID
      IW1 = IST + 1
      IW2 = LNL + 1
      IW3 = IW2 + IST
      IW4 = IW2 + LNL
      IW5 = IW4 + 3*IMID*NLAT
      LZZ1 = 2*NLAT*IMID
      LABC = 3* (MAX0(MMAX-2,0)* (NLAT+NLAT-MMAX-1))/2
      LWZVIN = LZZ1 + LABC
      JW1 = LWZVIN + 1
      JW2 = JW1 + LWZVIN
      CALL DVHSEC1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,V,W,MDAB,NDAB,BR,
     +             BI,CR,CI,IDV,WORK,WORK(IW1),WORK(IW2),WORK(IW3),
     +             WORK(IW4),WORK(IW5),WVHSEC,WVHSEC(JW1),WVHSEC(JW2))
      RETURN
      END
      SUBROUTINE DVHSEC1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,V,W,MDAB,NDAB,
     +                  BR,BI,CR,CI,IDV,VE,VO,WE,WO,VB,WB,WVBIN,WWBIN,
     +                  WRFFT)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION VE
      DOUBLE PRECISION VO
      DOUBLE PRECISION WE
      DOUBLE PRECISION WO
      DOUBLE PRECISION VB
      DOUBLE PRECISION WB
      DOUBLE PRECISION WVBIN
      DOUBLE PRECISION WWBIN
      DOUBLE PRECISION WRFFT
      DIMENSION V(IDVW,JDVW,1),W(IDVW,JDVW,1),BR(MDAB,NDAB,1),
     +          BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),
     +          VE(IDV,NLON,1),VO(IDV,NLON,1),WE(IDV,NLON,1),
     +          WO(IDV,NLON,1),WVBIN(1),WWBIN(1),WRFFT(1),
     +          VB(IMID,NLAT,3),WB(IMID,NLAT,3)

      NLP1 = NLAT + 1
      MLAT = MOD(NLAT,2)
      MLON = MOD(NLON,2)
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IMM1 = IMID
      IF (MLAT.NE.0) IMM1 = IMID - 1
      DO 10 K = 1,NT
          DO 10 J = 1,NLON
              DO 10 I = 1,IDV
                  VE(I,J,K) = 0.D0
                  WE(I,J,K) = 0.D0
   10 CONTINUE
      NDO1 = NLAT
      NDO2 = NLAT
      IF (MLAT.NE.0) NDO1 = NLAT - 1
      IF (MLAT.EQ.0) NDO2 = NLAT - 1
   18 ITYPP = ITYP + 1
      GO TO (1,100,200,300,400,500,600,700,800) ITYPP
c
c     case ityp=0   no symmetries
c
    1 CALL DVBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
c
c     case m = 0
c
      DO 15 K = 1,NT
          DO 15 NP1 = 2,NDO2,2
              DO 15 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1,IV)
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1,IV)
   15 CONTINUE
      DO 16 K = 1,NT
          DO 16 NP1 = 3,NDO1,2
              DO 16 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1,IV)
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1,IV)
   16 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 30 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 26
          DO 25 K = 1,NT
              DO 24 NP1 = MP1,NDO1,2
                  DO 23 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,NP1,IV)
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,NP1,IW)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,NP1,IV)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,NP1,IW)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,NP1,IV)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,NP1,IW)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,NP1,IV)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,NP1,IW)
   23             CONTINUE
                  IF (MLAT.EQ.0) GO TO 24
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,NP1,IW)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,NP1,IW)
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,NP1,IW)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,NP1,IW)
   24         CONTINUE
   25     CONTINUE
   26     IF (MP2.GT.NDO2) GO TO 30
          DO 29 K = 1,NT
              DO 28 NP1 = MP2,NDO2,2
                  DO 27 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,NP1,IV)
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,NP1,IW)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,NP1,IV)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,NP1,IW)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,NP1,IV)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,NP1,IW)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,NP1,IV)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,NP1,IW)
   27             CONTINUE
                  IF (MLAT.EQ.0) GO TO 28
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,NP1,IV)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,NP1,IV)
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,NP1,IV)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,NP1,IV)
   28         CONTINUE
   29     CONTINUE
   30 CONTINUE
      GO TO 950
c
c     case ityp=1   no symmetries,  cr and ci equal zero
c
  100 CALL DVBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
c
c     case m = 0
c
      DO 115 K = 1,NT
          DO 115 NP1 = 2,NDO2,2
              DO 115 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1,IV)
  115 CONTINUE
      DO 116 K = 1,NT
          DO 116 NP1 = 3,NDO1,2
              DO 116 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1,IV)
  116 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 130 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 126
          DO 125 K = 1,NT
              DO 124 NP1 = MP1,NDO1,2
                  DO 123 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,NP1,IV)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,NP1,IV)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,NP1,IW)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,NP1,IW)
  123             CONTINUE
                  IF (MLAT.EQ.0) GO TO 124
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,NP1,IW)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,NP1,IW)
  124         CONTINUE
  125     CONTINUE
  126     IF (MP2.GT.NDO2) GO TO 130
          DO 129 K = 1,NT
              DO 128 NP1 = MP2,NDO2,2
                  DO 127 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,NP1,IV)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,NP1,IV)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,NP1,IW)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,NP1,IW)
  127             CONTINUE
                  IF (MLAT.EQ.0) GO TO 128
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,NP1,IV)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,NP1,IV)
  128         CONTINUE
  129     CONTINUE
  130 CONTINUE
      GO TO 950
c
c     case ityp=2   no symmetries,  br and bi are equal to zero
c
  200 CALL DVBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
c
c     case m = 0
c
      DO 215 K = 1,NT
          DO 215 NP1 = 2,NDO2,2
              DO 215 I = 1,IMID
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1,IV)
  215 CONTINUE
      DO 216 K = 1,NT
          DO 216 NP1 = 3,NDO1,2
              DO 216 I = 1,IMM1
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1,IV)
  216 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 230 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 226
          DO 225 K = 1,NT
              DO 224 NP1 = MP1,NDO1,2
                  DO 223 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,NP1,IW)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,NP1,IW)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,NP1,IV)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,NP1,IV)
  223             CONTINUE
                  IF (MLAT.EQ.0) GO TO 224
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,NP1,IW)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,NP1,IW)
  224         CONTINUE
  225     CONTINUE
  226     IF (MP2.GT.NDO2) GO TO 230
          DO 229 K = 1,NT
              DO 228 NP1 = MP2,NDO2,2
                  DO 227 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,NP1,IW)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,NP1,IW)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,NP1,IV)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,NP1,IV)
  227             CONTINUE
                  IF (MLAT.EQ.0) GO TO 228
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,NP1,IV)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,NP1,IV)
  228         CONTINUE
  229     CONTINUE
  230 CONTINUE
      GO TO 950
c
c     case ityp=3   v even,  w odd
c
  300 CALL DVBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
c
c     case m = 0
c
      DO 315 K = 1,NT
          DO 315 NP1 = 2,NDO2,2
              DO 315 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1,IV)
  315 CONTINUE
      DO 316 K = 1,NT
          DO 316 NP1 = 3,NDO1,2
              DO 316 I = 1,IMM1
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1,IV)
  316 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 330 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 326
          DO 325 K = 1,NT
              DO 324 NP1 = MP1,NDO1,2
                  DO 323 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,NP1,IW)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,NP1,IW)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,NP1,IV)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,NP1,IV)
  323             CONTINUE
                  IF (MLAT.EQ.0) GO TO 324
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,NP1,IW)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,NP1,IW)
  324         CONTINUE
  325     CONTINUE
  326     IF (MP2.GT.NDO2) GO TO 330
          DO 329 K = 1,NT
              DO 328 NP1 = MP2,NDO2,2
                  DO 327 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,NP1,IV)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,NP1,IV)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,NP1,IW)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,NP1,IW)
  327             CONTINUE
                  IF (MLAT.EQ.0) GO TO 328
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,NP1,IV)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,NP1,IV)
  328         CONTINUE
  329     CONTINUE
  330 CONTINUE
      GO TO 950
c
c     case ityp=4   v even,  w odd, and both cr and ci equal zero
c
  400 CALL DVBIN(1,NLAT,NLON,0,VB,IV,WVBIN)
c
c     case m = 0
c
      DO 415 K = 1,NT
          DO 415 NP1 = 2,NDO2,2
              DO 415 I = 1,IMID
                  VE(I,1,K) = VE(I,1,K) + BR(1,NP1,K)*VB(I,NP1,IV)
  415 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 430 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(1,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(1,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP2.GT.NDO2) GO TO 430
          DO 429 K = 1,NT
              DO 428 NP1 = MP2,NDO2,2
                  DO 427 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,NP1,IV)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,NP1,IV)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,NP1,IW)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,NP1,IW)
  427             CONTINUE
                  IF (MLAT.EQ.0) GO TO 428
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) +
     +                                 BR(MP1,NP1,K)*VB(IMID,NP1,IV)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 BI(MP1,NP1,K)*VB(IMID,NP1,IV)
  428         CONTINUE
  429     CONTINUE
  430 CONTINUE
      GO TO 950
c
c     case ityp=5   v even,  w odd,     br and bi equal zero
c
  500 CALL DVBIN(2,NLAT,NLON,0,VB,IV,WVBIN)
c
c     case m = 0
c
      DO 516 K = 1,NT
          DO 516 NP1 = 3,NDO1,2
              DO 516 I = 1,IMM1
                  WO(I,1,K) = WO(I,1,K) - CR(1,NP1,K)*VB(I,NP1,IV)
  516 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 530 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(2,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(2,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 530
          DO 525 K = 1,NT
              DO 524 NP1 = MP1,NDO1,2
                  DO 523 I = 1,IMM1
                      VE(I,2*MP1-2,K) = VE(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,NP1,IW)
                      VE(I,2*MP1-1,K) = VE(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,NP1,IW)
                      WO(I,2*MP1-2,K) = WO(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,NP1,IV)
                      WO(I,2*MP1-1,K) = WO(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,NP1,IV)
  523             CONTINUE
                  IF (MLAT.EQ.0) GO TO 524
                  VE(IMID,2*MP1-2,K) = VE(IMID,2*MP1-2,K) -
     +                                 CI(MP1,NP1,K)*WB(IMID,NP1,IW)
                  VE(IMID,2*MP1-1,K) = VE(IMID,2*MP1-1,K) +
     +                                 CR(MP1,NP1,K)*WB(IMID,NP1,IW)
  524         CONTINUE
  525     CONTINUE
  530 CONTINUE
      GO TO 950
c
c     case ityp=6   v odd  ,  w even
c
  600 CALL DVBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
c
c     case m = 0
c
      DO 615 K = 1,NT
          DO 615 NP1 = 2,NDO2,2
              DO 615 I = 1,IMID
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1,IV)
  615 CONTINUE
      DO 616 K = 1,NT
          DO 616 NP1 = 3,NDO1,2
              DO 616 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1,IV)
  616 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 630 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 626
          DO 625 K = 1,NT
              DO 624 NP1 = MP1,NDO1,2
                  DO 623 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,NP1,IV)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,NP1,IV)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,NP1,IW)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,NP1,IW)
  623             CONTINUE
                  IF (MLAT.EQ.0) GO TO 624
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,NP1,IW)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,NP1,IW)
  624         CONTINUE
  625     CONTINUE
  626     IF (MP2.GT.NDO2) GO TO 630
          DO 629 K = 1,NT
              DO 628 NP1 = MP2,NDO2,2
                  DO 627 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,NP1,IW)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,NP1,IW)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,NP1,IV)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,NP1,IV)
  627             CONTINUE
                  IF (MLAT.EQ.0) GO TO 628
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,NP1,IV)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,NP1,IV)
  628         CONTINUE
  629     CONTINUE
  630 CONTINUE
      GO TO 950
c
c     case ityp=7   v odd, w even   cr and ci equal zero
c
  700 CALL DVBIN(2,NLAT,NLON,0,VB,IV,WVBIN)
c
c     case m = 0
c
      DO 716 K = 1,NT
          DO 716 NP1 = 3,NDO1,2
              DO 716 I = 1,IMM1
                  VO(I,1,K) = VO(I,1,K) + BR(1,NP1,K)*VB(I,NP1,IV)
  716 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 730 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(2,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(2,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 730
          DO 725 K = 1,NT
              DO 724 NP1 = MP1,NDO1,2
                  DO 723 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) +
     +                                  BR(MP1,NP1,K)*VB(I,NP1,IV)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  BI(MP1,NP1,K)*VB(I,NP1,IV)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  BI(MP1,NP1,K)*WB(I,NP1,IW)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) +
     +                                  BR(MP1,NP1,K)*WB(I,NP1,IW)
  723             CONTINUE
                  IF (MLAT.EQ.0) GO TO 724
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 BI(MP1,NP1,K)*WB(IMID,NP1,IW)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) +
     +                                 BR(MP1,NP1,K)*WB(IMID,NP1,IW)
  724         CONTINUE
  725     CONTINUE
  730 CONTINUE
      GO TO 950
c
c     case ityp=8   v odd,  w even   br and bi equal zero
c
  800 CALL DVBIN(1,NLAT,NLON,0,VB,IV,WVBIN)
c
c     case m = 0
c
      DO 815 K = 1,NT
          DO 815 NP1 = 2,NDO2,2
              DO 815 I = 1,IMID
                  WE(I,1,K) = WE(I,1,K) - CR(1,NP1,K)*VB(I,NP1,IV)
  815 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) GO TO 950
      DO 830 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(1,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(1,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP2.GT.NDO2) GO TO 830
          DO 829 K = 1,NT
              DO 828 NP1 = MP2,NDO2,2
                  DO 827 I = 1,IMM1
                      VO(I,2*MP1-2,K) = VO(I,2*MP1-2,K) -
     +                                  CI(MP1,NP1,K)*WB(I,NP1,IW)
                      VO(I,2*MP1-1,K) = VO(I,2*MP1-1,K) +
     +                                  CR(MP1,NP1,K)*WB(I,NP1,IW)
                      WE(I,2*MP1-2,K) = WE(I,2*MP1-2,K) -
     +                                  CR(MP1,NP1,K)*VB(I,NP1,IV)
                      WE(I,2*MP1-1,K) = WE(I,2*MP1-1,K) -
     +                                  CI(MP1,NP1,K)*VB(I,NP1,IV)
  827             CONTINUE
                  IF (MLAT.EQ.0) GO TO 828
                  WE(IMID,2*MP1-2,K) = WE(IMID,2*MP1-2,K) -
     +                                 CR(MP1,NP1,K)*VB(IMID,NP1,IV)
                  WE(IMID,2*MP1-1,K) = WE(IMID,2*MP1-1,K) -
     +                                 CI(MP1,NP1,K)*VB(IMID,NP1,IV)
  828         CONTINUE
  829     CONTINUE
  830 CONTINUE
  950 DO 14 K = 1,NT
          CALL DHRFFTB(IDV,NLON,VE(1,1,K),IDV,WRFFT,VB)
          CALL DHRFFTB(IDV,NLON,WE(1,1,K),IDV,WRFFT,VB)
   14 CONTINUE
      IF (ITYP.GT.2) GO TO 12
      DO 60 K = 1,NT
          DO 60 J = 1,NLON
              DO 60 I = 1,IMM1
                  V(I,J,K) = .5D0* (VE(I,J,K)+VO(I,J,K))
                  W(I,J,K) = .5D0* (WE(I,J,K)+WO(I,J,K))
                  V(NLP1-I,J,K) = .5D0* (VE(I,J,K)-VO(I,J,K))
                  W(NLP1-I,J,K) = .5D0* (WE(I,J,K)-WO(I,J,K))
   60 CONTINUE
      GO TO 13
   12 DO 11 K = 1,NT
          DO 11 J = 1,NLON
              DO 11 I = 1,IMM1
                  V(I,J,K) = .5D0*VE(I,J,K)
                  W(I,J,K) = .5D0*WE(I,J,K)
   11 CONTINUE
   13 IF (MLAT.EQ.0) RETURN
      DO 65 K = 1,NT
          DO 65 J = 1,NLON
              V(IMID,J,K) = .5D0*VE(IMID,J,K)
              W(IMID,J,K) = .5D0*WE(IMID,J,K)
   65 CONTINUE
      RETURN
      END
      SUBROUTINE DVHSECI(NLAT,NLON,WVHSEC,LVHSEC,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WVHSEC
      DIMENSION WVHSEC(LVHSEC)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.1) RETURN
      IERROR = 3
      IMID = (NLAT+1)/2
      LZZ1 = 2*NLAT*IMID
      MMAX = MIN0(NLAT, (NLON+1)/2)
      LABC = 3* (MAX0(MMAX-2,0)* (NLAT+NLAT-MMAX-1))/2
      IF (LVHSEC.LT.2* (LZZ1+LABC)+NLON+15) RETURN
      IERROR = 4
      IF (LDWORK.LT.2*NLAT+2) RETURN
      IERROR = 0
      CALL DVBINIT(NLAT,NLON,WVHSEC,DWORK)
      LWVBIN = LZZ1 + LABC
      IW1 = LWVBIN + 1
      CALL DWBINIT(NLAT,NLON,WVHSEC(IW1),DWORK)
      IW2 = IW1 + LWVBIN
      CALL DHRFFTI(NLON,WVHSEC(IW2))
      RETURN
      END


Real Function fmassr(dmass)
  Save
  am0 = 0.77
  wid = 0.153
  fmassr = am0*wid/((dmass**2-am0**2)**2+am0**2*wid**2)
  Return
End Function fmassr


      SUBROUTINE UHARD(SYIELD,HARD,EQPLAS,EQPLASRT,TIME,DTIME,TEMP,
     1     DTEMP,NOEL,NPT,LAYER,KSPT,KSTEP,KINC,CMNAME,NSTATV,
     2     STATEV,NUMFIELDV,PREDEF,DPRED,NUMPROPS,PROPS)
C
	  INCLUDE '../aba_param_dp.INC'
C
	  CHARACTER*80 CMNAME
	  DIMENSION HARD(3), STATEV(NSTATV), TIME(1), PREDEF(NUMFIELDV), DPRED(NUMFIELDV), PROPS(*)
	  REAL*8 A,B,n0,n1,C,m,e,edot,T,Tr,Tm,Th,einv,edinv,edlog,D0,Dlog
	  REAL*8 Ehard, Ehard_e, Ehard_ed, EDhard, EDhard_ed, Tsoft, Tsoft_T
      A = PROPS(1)
      B = PROPS(2)
      n0 = PROPS(3)
      n1 = PROPS(4)
      C = PROPS(5)
      m = PROPS(6)
      Tr = PROPS(7)
      Tm = PROPS(8)

      D0 = 1.0D6
      Dlog = log(D0)
      e = max(EQPLAS, 1.0D-6)
      einv = 1.0D0 / max(e, 1.0D-2)
      edot = max(EQPLASRT, 1.0D-6)
      edlog = max(log(edot), 1.0D-2)
      edinv = 1.0D0 / max(edot, 1.0D-2)
      T = TEMP
      Th = (T - Tr) / (Tm - Tr)
      Th = min(1.0D0, max(0.0D0, Th))

      Ehard = A + B * (e ** n0) * ((1.0D0 - (edlog/Dlog)) ** n1)
      Ehard_e = B * n0 * (einv ** (1.0D0 - n0)) * (1 - (edlog/Dlog) ** n1)
      Ehard_ed = - B * (e ** n0) * ((edinv / Dlog) ** n1) * n1 * ((Dlog/edlog) ** (1.0D0 - n1))

      EDhard = edot ** C
      EDhard_ed = C * edinv ** (1.0D0 - C)

      Tsoft = 1.0D0 - Th ** m
      Tsoft_T = m * (Th ** m) / min(Tr - T, -1.0D-3)

      SYIELD = Ehard * EDhard * Tsoft
      HARD(1) = Ehard_e * EDhard * Tsoft
      HARD(2) = Ehard * EDhard_ed * Tsoft + Ehard_ed * EDhard * Tsoft
      HARD(3) = Ehard * EDhard * Tsoft_T

      RETURN
      END

      SUBROUTINE VUHARD(
C READ ONLY -
     *     NBLOCK,
     *     JELEM, KINTPT, KLAYER, KSECPT,
     *     LANNEAL, STEPTIME, TOTALTIME, DT, CMNAME,
     *     NSTATEV, NFIELDV, NPROPS,
     *     PROPS, TEMPOLD, TEMPNEW, FIELDOLD, FIELDNEW,
     *     STATEOLD,
     *     EQPS, EQPSRATE,
C WRITE ONLY -
     *     YIELD, DYIELDDTEMP, DYIELDDEQPS,
     *     STATENEW )
C
      INCLUDE '../vaba_param_dp.INC'
C
      DIMENSION PROPS(NPROPS), TEMPOLD(NBLOCK), TEMPNEW(NBLOCK),
     1   FIELDOLD(NBLOCK,NFIELDV), FIELDNEW(NBLOCK,NFIELDV),
     2   STATEOLD(NBLOCK,NSTATEV), EQPS(NBLOCK), EQPSRATE(NBLOCK),
     3   YIELD(NBLOCK), DYIELDDTEMP(NBLOCK), DYIELDDEQPS(NBLOCK,2),
     4   STATENEW(NBLOCK,NSTATEV), JELEM(NBLOCK)
C
      CHARACTER*80 CMNAME
C
	  REAL*8 A,B,n0,n1,C,m,e,edot,T,Tr,Tm,Th,einv,edinv,edlog,D0,Dlog
	  REAL*8 Ehard, Ehard_e, Ehard_ed, EDhard, EDhard_ed, Tsoft, Tsoft_T

      DO 100 km = 1,NBLOCK
          A = PROPS(1)
          B = PROPS(2)
          n0 = PROPS(3)
          n1 = PROPS(4)
          C = PROPS(5)
          m = PROPS(6)
          Tr = PROPS(7)
          Tm = PROPS(8)

          D0 = 1.0D6
          Dlog = log(D0)
          e = max(EQPS(km), 1.0D-6)
          einv = 1.0D0 / max(e, 1.0D-2)
          edot = max(EQPSRATE(km), 1.0D-6)
          edlog = max(log(edot), -1.0D-3)
          edinv = 1.0D0 / max(edot, 1.0D-2)
          T = TEMPOLD(km)
          Th = (T - Tr) / (Tm - Tr)
          Th = min(1.0D0, max(0.0D0, Th))

          Ehard = A + B * (e ** n0) * ((1.0D0 - (edlog/Dlog)) ** n1)
          Ehard_e = B * n0 * (einv ** (1.0D0 - n0)) * (1.0D0 - (edlog/Dlog)) ** n1
          Ehard_ed = - B * (e ** n0) * (n1 * (1.0D0 - (edlog/Dlog)) ** (n1 - 1.0D0)) * edinv / Dlog

          EDhard = edot ** C
          EDhard_ed = C * edinv ** (1.0D0 - C)

          Tsoft = 1.0D0 - Th ** m
          Tsoft_T = m * (Th ** m) / min(Tr - T, -1.0D-3)

          YIELD(km) = Ehard * EDhard * Tsoft
          DYIELDDEQPS(km,1) = Ehard_e * EDhard * Tsoft
          DYIELDDEQPS(km,2) = Ehard * EDhard_ed * Tsoft + Ehard_ed * EDhard * Tsoft
          DYIELDDTEMP(km) = Ehard * EDhard * Tsoft_T
  100 CONTINUE
C
      RETURN
      END


      FUNCTION bnldev(pp,n,idum)
      INTEGER idum,n
      REAL bnldev,pp,PI
CU    USES gammln,ran1
      PARAMETER (PI=3.141592654)
      INTEGER j,nold
      REAL am,em,en,g,oldg,p,pc,pclog,plog,pold,sq,t,y,gammln,ran1
      SAVE nold,pold,pc,plog,pclog,en,oldg
      DATA nold /-1/, pold /-1./
      if(pp.le.0.5)then
        p=pp
      else
        p=1.-pp
      endif
      am=n*p
      if (n.lt.25)then
        bnldev=0.
        do 11 j=1,n
          if(ran1(idum).lt.p)bnldev=bnldev+1.
11      continue
      else if (am.lt.1.) then
        g=exp(-am)
        t=1.
        do 12 j=0,n
          t=t*ran1(idum)
          if (t.lt.g) goto 1
12      continue
        j=n
1       bnldev=j
      else
        if (n.ne.nold) then
          en=n
          oldg=gammln(en+1.)
          nold=n
        endif
        if (p.ne.pold) then
          pc=1.-p
          plog=log(p)
          pclog=log(pc)
          pold=p
        endif
        sq=sqrt(2.*am*pc)
2       y=tan(PI*ran1(idum))
        em=sq*y+am
        if (em.lt.0..or.em.ge.en+1.) goto 2
        em=int(em)
        t=1.2*sq*(1.+y**2)*exp(oldg-gammln(em+1.)-gammln(en-em+1.)+em*
     *plog+(en-em)*pclog)
        if (ran1(idum).gt.t) goto 2
        bnldev=em
      endif
      if (p.ne.pp) bnldev=n-bnldev
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/bnldev.for


! Calculate power spectrum P(k) of the 3-D Fourier transform of a scalar field (as opposed to the FT along 1-D pencils).

subroutine calc_ps3d (overdensity_fft_real, overdensity_fft_imag, lo, hi, ng, num_bins, k_bin_edges, domain_length, &
                      domain_grid_length, k_bin_count, k_bin_power_weighted_k_sum, k_bin_power_sum)

  use, intrinsic :: iso_c_binding
  implicit none

  integer(c_int), intent(in) :: lo(3), hi(3), ng, num_bins
  real(c_double), intent(in), target :: overdensity_fft_real (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
  real(c_double), intent(in), target :: overdensity_fft_imag (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
  real(c_double), intent(in) :: k_bin_edges (num_bins+1)
  real(c_double), intent(in) :: domain_length
  integer(c_int), intent(in) :: domain_grid_length

  integer(c_int), intent(out) :: k_bin_count (num_bins)
  real(c_double), intent(out) :: k_bin_power_weighted_k_sum (num_bins)
  real(c_double), intent(out) :: k_bin_power_sum (num_bins)

  integer(c_int) :: i, j, k
  integer(c_int) :: kk
  integer(c_int) :: k_bin_index
  integer(c_int) :: k_index_i, k_index_j, k_index_k

  real(c_double) :: k_fund
  real(c_double) :: k_mag
  real(c_double) :: k_max
  real(c_double) :: k_min
  real(c_double) :: p_i
  real(c_double) :: pi

  pi = acos(-1.0)

  k_fund = 2.0 * pi / domain_length

  k_min = minval(k_bin_edges)
  k_max = maxval(k_bin_edges)

  k_bin_count (:) = 0
  k_bin_power_weighted_k_sum (:) = 0.0
  k_bin_power_sum (:) = 0.0

  do k = lo(3), hi(3)
    do j = lo(2), hi(2)
      do i = lo(1), hi(1)

        ! Calculate grid points in k-space.
        if (i <= domain_grid_length/2) then
          k_index_i = i
        else
          k_index_i = i-domain_grid_length
        end if
        if (j <= domain_grid_length/2) then
          k_index_j = j
        else
          k_index_j = j-domain_grid_length
        end if
        if (k <= domain_grid_length/2) then
          k_index_k = k
        else
          k_index_k = k-domain_grid_length
        end if

        ! Skip 0 mode.
        if ((k_index_i == 0) .and. (k_index_j == 0) .and. (k_index_k == 0)) cycle

        ! Calculate magnitude of k vector.
        k_mag = k_fund * sqrt(real(k_index_i*k_index_i + k_index_j*k_index_j + k_index_k*k_index_k, c_double))

        ! Skip value if out of bounds.
        if ((k_mag < k_min) .or. (k_mag >= k_max)) cycle

        ! Find matching k bin.
        k_bin_index = -1
        do kk = 1, num_bins
        if (k_mag >= k_bin_edges(kk) .and. k_mag < k_bin_edges(kk+1)) then
            k_bin_index = kk
              exit
          end if
        end do
        if (k_bin_index < 0) stop 'COULD NOT MATCH K BIN'

        p_i = (overdensity_fft_real(i, j, k, 1)**2 + overdensity_fft_imag(i, j, k, 1)**2) / domain_length**3

        k_bin_count                (k_bin_index) = k_bin_count                (k_bin_index) + 1
        k_bin_power_weighted_k_sum (k_bin_index) = k_bin_power_weighted_k_sum (k_bin_index) + k_mag*p_i
        k_bin_power_sum            (k_bin_index) = k_bin_power_sum            (k_bin_index) + p_i

      end do
    end do
  end do

end subroutine calc_ps3d


program problem49
  use euler
  implicit none
  integer :: i,j,k

  do i=1000,9999
     if (.not. is_prime(int8(i))) cycle

     do j=i+1,9999
        if (.not. is_prime(int8(j))) cycle
        if (.not. permutations(i,j)) cycle

        do k=j+1,9999
           if (.not. is_prime(int8(k))) cycle
           if (.not. permutations(j, k)) cycle
           if (j - i == k - j) print *, i, j, k
        end do

     end do

  end do

contains

  pure function permutations(a,b)
    implicit none
    integer, intent(in)    :: a,b
    integer, dimension(10) :: a_ar, b_ar
    integer                :: i,temp,a_curr,b_curr
    logical                :: permutations

    do i=1,10
       a_ar(i)=0
       b_ar(i)=0
    end do

    a_curr=a
    b_curr=b

    do i=1,4
       temp=mod(a_curr,10)+1
       a_ar(temp)=a_ar(temp)+1

       temp=mod(b_curr,10)+1
       b_ar(temp)=b_ar(temp)+1

       a_curr=a_curr/10
       b_curr=b_curr/10
    end do

    permutations=all(a_ar == b_ar,1)

  end function permutations

end program problem49


module constants

	implicit none
	integer,  parameter :: dp = kind(1.d0)
	real(dp), parameter :: PI = 4.0_dp*datan(1.0_dp)
	! Raw Constants (Gaussian 16)
	real(dp), parameter :: bohr = 0.52917721092e0_dp ! Ang
	real(dp), parameter :: amu = 1.660538921e-27_dp ! kg
	real(dp), parameter :: e_charge  = 1.602176565e-19_dp ! C
	real(dp), parameter :: planck_h  = 6.62606957e-34_dp ! Joule-second
	real(dp), parameter :: avogadro_Na = 6.02214129e23_dp ! part/mol
	real(dp), parameter :: hartree =  4.35974434e-18_dp ! Joules
	real(dp), parameter :: light_speed = 2.99792458e10_dp ! cm/sec
	real(dp), parameter :: boltzmann_k = 1.3806488e-23_dp !Joules/degree
	real(dp), parameter :: eV_to_mdyn_Ang = 1.602176565e-1_dp ! mdyna/Ang

	! Conversion factors
	real(dp), parameter :: e_mass = 0.910938291e-30_dp ! kg
	real(dp), parameter :: p_mass = 1836.15267245e0_dp*e_mass ! kg
	real(dp), parameter :: eV_to_J = 1.602176565e-19_dp ! Joules
	real(dp), parameter :: eV_to_kcal_per_mol = 23.06e0_dp ! kcal/mol
	real(dp), parameter :: hartree_to_kcal_per_mol = 627.5095e0_dp ! kcal/mol
	real(dp), parameter :: hartree_to_eV = 27.2114e0_dp ! eV
	real(dp), parameter :: hartree_to_cm = 219474.63e0_dp ! cm^-1 (vibrational freq. au)

end module constants


c-------------------------------------------------------------
c PROGRAM 	: ROOT FINDING - FALSE POSITION METHOD
c
c SUBJECT   : 640-364 COMPUTATIONAL PHYSICS
c NAME      : MICHAEL PAPASIMEON
c DATE      : 06/08/1997
c
c PURPOSE   : This program does a numerical integration
c           : between 0 and 1 for the function ln(1+x)/x
c           : using both the Trapezoidal and Simpsons
c           : rules for quadrature.
c-------------------------------------------------------------

      program main
      implicit none
      integer*4 n, i
      real*8 result, false_position, tolx, answer, error

      answer = dsqrt(3.0d0)

      n = 10
      tolx = 1.0d0/dfloat(n)
      do 10 i = 0, 6, +1
            result = false_position(n, 1.0d0, tolx)
            error = dabs(result - answer)
            write(*,15)n, tolx, result, error
15          format(i10, f14.10, f14.10, g14.6)
            n = n*10
            tolx = 1.0d0/dfloat(n)
10    continue
      end

c-------------------------------------------------------------
c FUNCTION	: g
c PURPOSE	: returns t**2
c-------------------------------------------------------------

      double precision function g(t)
      implicit none
      real*8 t
      g = t**2
      return
      end

c-------------------------------------------------------------
c SUBROUTINE	: simpson
c PURPOSE		: calculates the integral between a and b
c               : for the function g(x)
c-------------------------------------------------------------

      double precision function simpson(n, a, b)
      implicit none
      integer*4 n, i, factor
      real*8 a, b
      real*8 h, sum, x, g

      i = 0
      factor = 4
      sum = 0.0d0
      x = 0.0d0
      h = (b-a)/dfloat(n)

      do 300 i = 1, (n-1), +1
            x = a+i*h
            if (factor .eq. 2) then
                  sum = sum + 2.0d0*g(x)
                  factor = 4
            else
                  sum = sum + 4.0d0*g(x)
                  factor = 2
            endif
300   continue
      sum = sum + g(a) + g(b)
      sum = (h*sum)/3.0d0

     simpson = sum
     return

     end

c-------------------------------------------------------------
c FUNCTION  : f
c PURPOSE   : calculates and returns the value of the function
c           : of the integral between a and b of the function
c           : g(x) determined by the simpson function minus
c           : c. When a = 0 and b = x, we have
c           : f = Integrate[t**2 dt,0,x] - x
c-------------------------------------------------------------

      double precision function f(n,a,b)
      implicit none
      integer*4 n
      real*8 a, b, simpson
      f = simpson(n,a,b) - b
      return
      end

c-------------------------------------------------------------
c FUNCTION  : false_position
c PURPOSE   : calculates and returns the root of the function
c           : f, after position x1, to a tolerance of tolx
c           : using the false position method. The parameter
c           : n determines the accuracy to which the function
c           : f can be calculated to.
c-------------------------------------------------------------

      double precision function false_position(n, x1, tolx)
      implicit none
      integer*4 n
      real*8 x1, tolx
      real*8 f
      real*8 x2, f1, f2, x3, f3, h, a

      a = 0.0d0
      h = 0.33

      x2 = x1 + h
      f1 = f(n,a,x1)
      f2 = f(n,a,x2)

      do while (f1*f2 .ge. 0.0d0)
            x2 = x2 + h
            f2 = f(n,a,x2)
      end do

      x3 = x2 - f2*(x2-x1)/(f2-f1)
      f3 = f(n,a,x3)

      do while (dabs(f3) .gt. tolx)
            if (f1*f3 .lt. 0.0d0) then
                  x2 = x3
            else
                  x1 = x3
            endif
            f1 = f(n,a,x1)
            f2 = f(n,a,x2)
            x3 = x2 - f2*(x2-x1)/(f2-f1)
            f3 = f(n,a,x3)
      end do

      false_position = x3
      return

      end


      SUBROUTINE orthog(n,anu,alpha,beta,a,b)
      INTEGER n,NMAX
      REAL a(n),alpha(2*n-1),anu(2*n),b(n),beta(2*n-1)
      PARAMETER (NMAX=64)
      INTEGER k,l
      REAL sig(2*NMAX+1,2*NMAX+1)
      do 11 l=3,2*n
        sig(1,l)=0.
11    continue
      do 12 l=2,2*n+1
        sig(2,l)=anu(l-1)
12    continue
      a(1)=alpha(1)+anu(2)/anu(1)
      b(1)=0.
      do 14 k=3,n+1
        do 13 l=k,2*n-k+3
          sig(k,l)=sig(k-1,l+1)+(alpha(l-1)-a(k-2))*sig(k-1,l)-b(k-2)*
     *sig(k-2,l)+beta(l-1)*sig(k-1,l-1)
13      continue
        a(k-1)=alpha(k-1)+sig(k,k+1)/sig(k,k)-sig(k-1,k)/sig(k-1,k-1)
        b(k-1)=sig(k,k)/sig(k-1,k-1)
14    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/orthog.for


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Mon May 20 23:05:46
!
!a=./f && make $a && $a < unixdict.txt
!gfortran -std=f2003 -Wall -ffree-form f.f03 -o f
!
!ternary not
! 1.0 0.5 0.0
!
!
!ternary and
! 0.0 0.0 0.0
! 0.0 0.5 0.5
! 0.0 0.5 1.0
!
!
!ternary or
! 0.0 0.5 1.0
! 0.5 0.5 1.0
! 1.0 1.0 1.0
!
!
!ternary if
! 1.0 1.0 1.0
! 0.5 0.5 1.0
! 0.0 0.5 1.0
!
!
!ternary eq
! 1.0 0.5 0.0
! 0.5 0.5 0.5
! 0.0 0.5 1.0
!
!
!Compilation finished at Mon May 20 23:05:46

!This program is based on the j implementation
!not=: -.
!and=: <.
!or =: >.
!if =: (>. -.)"0~
!eq =: (<.&-. >. <.)"0

module trit

  real, parameter :: true = 1,  false = 0, maybe = 0.5

contains

  real function tnot(y)
    real, intent(in) :: y
    tnot = 1 - y
  end function tnot

  real function tand(x, y)
    real, intent(in) :: x, y
    tand = min(x, y)
  end function tand

  real function tor(x, y)
    real, intent(in) :: x, y
    tor = max(x, y)
  end function tor

  real function tif(x, y)
    real, intent(in) :: x, y
    tif = tor(y, tnot(x))
  end function tif

  real function teq(x, y)
    real, intent(in) :: x, y
    teq = tor(tand(tnot(x), tnot(y)), tand(x, y))
  end function teq

end module trit

program ternaryLogic
  use trit
  integer :: i
  real, dimension(3) :: a = [false, maybe, true] ! (/ ... /)
  write(6,'(/a)')'ternary not' ; write(6, '(3f4.1/)') (tnot(a(i)), i = 1 , 3)
  write(6,'(/a)')'ternary and' ; call table(tand, a, a)
  write(6,'(/a)')'ternary or' ; call table(tor, a, a)
  write(6,'(/a)')'ternary if' ; call table(tif, a, a)
  write(6,'(/a)')'ternary eq' ; call table(teq, a, a)

contains

  subroutine table(u, x, y) ! for now, show the table.
    real, external :: u
    real, dimension(3), intent(in) :: x, y
    integer :: i, j
    write(6, '(3(3f4.1/))') ((u(x(i), y(j)), j=1,3), i=1,3)
  end subroutine table

end program ternaryLogic


      double precision function bnorm (n, a, nra, ml, mu, w)
clll. optimize
c-----------------------------------------------------------------------
c this function computes the norm of a banded n by n matrix,
c stored in the array a, that is consistent with the weighted max-norm
c on vectors, with weights stored in the array w.
c ml and mu are the lower and upper half-bandwidths of the matrix.
c nra is the first dimension of the a array, nra .ge. ml+mu+1.
c in terms of the matrix elements a(i,j), the norm is given by..
c   bnorm = max(i=1,...,n) ( w(i) * sum(j=1,...,n) abs(a(i,j))/w(j) )
c-----------------------------------------------------------------------
      integer n, nra, ml, mu
      integer i, i1, jlo, jhi, j
      double precision a, w
      double precision an, sum
      dimension a(nra,n), w(n)
      an = 0.0d0
      do 20 i = 1,n
        sum = 0.0d0
        i1 = i + mu + 1
        jlo = max0(i-ml,1)
        jhi = min0(i+mu,n)
        do 10 j = jlo,jhi
 10       sum = sum + dabs(a(i1-j,j))/w(j)
        an = dmax1(an,sum*w(i))
 20     continue
      bnorm = an
      return
c----------------------- end of function bnorm -------------------------
      end


module Task
use omp_lib
implicit none

contains

     subroutine GetMaxCoordinates(A, x1, y1, x2, y2)
     implicit none

     ! Входные и выходные данные
     real(8), dimension(:,:), intent(in) :: A
     integer(4), intent(out) :: x1, y1, x2, y2

     ! Вспомогательные переменные
     integer ier

     ! Переменные для работы алгоритма Кадане
     integer(4) :: n, L, R, Up, Down, m, tmp, thr_id, thr_num, thr_max
     real(8), allocatable :: current_column(:,:), B(:,:)
     real(8) :: current_sum
     logical :: transpos

     ! Переменные для определения результата
     real(8), allocatable, dimension(:) :: max_sum
     integer(4), allocatable, dimension(:):: X_1, X_2, Y_1, Y_2

     m = size(A, dim=1)
     n = size(A, dim=2)
     transpos = .FALSE.

     if (m .lt. n) then

          transpos = .TRUE.
          B = transpose(A)
          m = size(B, dim=1)
          n = size(B, dim=2)

     else

          B = A

     endif

     thr_num = omp_get_max_threads()

     ! Выделение памяти под массивы

     allocate(current_column(m,0:thr_num-1), stat = ier)
     if (ier .ne. 0) stop 'Не могу выделить память для массива current_column'

     allocate(X_1(0:thr_num-1), stat = ier)
     if (ier .ne. 0) stop 'Не могу выделить память для массива X_1'
     allocate(X_2(0:thr_num-1), stat = ier)
     if (ier .ne. 0) stop 'Не могу выделить память для массива X_2'
     allocate(Y_1(0:thr_num-1), stat = ier)
     if (ier .ne. 0) stop 'Не могу выделить память для массива Y_1'
     allocate(Y_2(0:thr_num-1), stat = ier)
     if (ier .ne. 0) stop 'Не могу выделить память для массива Y_2'

     allocate(max_sum(0:thr_num-1), stat = ier)
     if (ier .ne. 0) stop 'Не могу выделить память для массива max_sum'

     max_sum = B(1,1)
     X_1 = 1
     Y_1 = 1
     X_2 = 1
     Y_2 = 1

     !$omp parallel do private(R,L,current_sum,thr_id,Up,Down) shared(B,n,m,current_column,max_sum,X_1,Y_1,X_2,Y_2) default(none) schedule(dynamic)

     do L = 1, n

          thr_id = omp_get_thread_num()
          current_column(:,thr_id) = B(:, L)

          do R = L, n

               if (R .gt. L) then

                    current_column(:,thr_id) = current_column(:,thr_id) + B(:, R)

               endif

               call FindMaxInArray(current_column(:,thr_id), current_sum, Up, Down)

               if (current_sum > max_sum(thr_id)) then

                    max_sum(thr_id) = current_sum
                    X_1(thr_id) = Up
                    X_2(thr_id) = Down
                    Y_1(thr_id) = L
                    Y_2(thr_id) = R

               endif

          end do

     end do

     !$omp end parallel do

     thr_max = maxloc(max_sum, dim=1)

     x1 = X_1(thr_max-1)
     x2 = X_2(thr_max-1)
     y1 = Y_1(thr_max-1)
     y2 = Y_2(thr_max-1)

     if (transpos) then

          tmp = x1
          x1 = y1
          y1 = tmp

          tmp = y2
          y2 = x2
          x2 = tmp

     endif

     deallocate(current_column)
     deallocate(max_sum, X_1, X_2, Y_1, Y_2)

     end subroutine

     subroutine FindMaxInArray(a, ans, Up, Down)
     implicit none

     real(8), intent(in), dimension(:) :: a
     integer(4), intent(out) :: Up, Down
     real(8), intent(out) :: ans
     real(8) :: cur, sum, min_sum
     integer(4) :: min_pos, i

     ans = a(1)
     Up = 1
     Down = 1
     sum = 0d0
     min_sum = 0d0
     min_pos = 0

     do i = 1, size(a)

          sum = sum + a(i)
          cur = sum - min_sum

          if (cur .gt. ans) then

               ans = cur
               Up = min_pos + 1
               Down = i

          endif

          if (sum .lt. min_sum) then

               min_sum = sum
               min_pos = i

          endif

     enddo

     end subroutine FindMaxInArray

end module Task


      subroutine dsearchc(X, m, val, n, indX, occ, info)
*
*
*     PURPOSE
*        val(0..n) being an array (with strict increasing order and n >=1)
*        representing intervals, this routine, by the mean of a
*        dichotomic search, computes :
*
*           a/ for each X(i) its interval number indX(i) :
*                     indX(i) = j if  X(i) in (val(j-1), val(j)]
*                             = 1 if  X(i) = val(0)
*                             = 0 if  X(i) is not in [val(0),val(n)]
*
*           b/ the number of points falling in the interval j :
*
*              occ(j) = # { X(i) such that X(i) in (val(j-1), val(j)] } for j>1
*         and  occ(1) = # { X(i) such that X(i) in [val(0), val(1)] }
*
*     PARAMETERS
*        inputs :
*           m         integer
*           X(1..m)   double float array
*           n         integer
*           val(0..n) double float array (val(0) < val(1) < ....)
*        outputs
*           indX(1..m) integer array
*           occ(1..n)  integer array
*           info       integer (number of X(i) not in [val(0), val(n)])
*
*     AUTHOR
*        Bruno Pincon
*
      implicit none
      integer m, n, info
      double precision X(m), val(0:n)
      integer occ(n), indX(m)

      integer i, j1, j2, j

      do j = 1, n
         occ(j) = 0
      enddo

      info = 0

      do i = 1, m
         if ( val(0) .le. X(i) .and. X(i) .le. val(n) ) then
*           X(i) is in [val(0),val(n)] :
*           find j such that val(j-1) <= X(i) <= val(j) by a dicho search
            j1 = 0
            j2 = n
            do while ( j2 - j1 .gt. 1 )
               j = (j1 + j2)/2
               if ( X(i) .le. val(j) ) then
                  j2 = j
               else
                  j1 = j
               endif
            enddo
*           we have val(j1) < X(i) <= val(j2)  if j2 > 1  (j1=j2-1)
*                or val(j1) <= X(i) <= val(j2) if j2 = 1  (j1=j2-1)
*           so that j2 is the good interval number in all cases
            occ(j2) = occ(j2) + 1
            indX(i) = j2
         else     ! X(i) is not in [val(0), val(n)]
            info = info + 1
            indX(i) = 0
         endif
      enddo

      end
*
**************************************************************************
*
      subroutine dsearchd(X, m, val, n, indX, occ, info)
*
*     PURPOSE
*        val(1..n) being a strictly increasing array, this
*        routines by the mean of a dichotomic search computes :
*
*        a/ the number of occurences (occ(j)) of each value val(j)
*           in the array X :
*
*              occ(j) = #{ X(i) such that X(i) = val(j) }
*
*        b/ the array indX :  if X(i) = val(j) then indX(i) = j
*           (if X(i) is not in val then indX(i) = 0)
*
*     PARAMETERS
*        inputs :
*           m         integer
*           X(1..m)   double float array
*           n         integer
*           val(1..n) double float array (must be in a strict increasing order)
*        outputs :
*           occ(1..n)  integer array
*           indX(1..m) integer array
*           info       integer  (number of X(i) which are not in val(1..n))
*
*     AUTHOR
*        Bruno Pincon
*
      implicit none
      integer m, n, info
      double precision X(m), val(n)
      integer occ(n), indX(m)

      integer i, j1, j2, j

      do j = 1, n
         occ(j) = 0
      enddo

      info = 0

      do i = 1, m
         if ( val(1) .le. X(i) .and. X(i) .le. val(n) ) then
*           find j such that X(i) = val(j) by a dicho search
            j1 = 1
            j2 = n
            do while ( j2 - j1 .gt. 1 )
               j = (j1 + j2)/2
               if ( X(i) .lt. val(j) ) then
                  j2 = j
               else
                  j1 = j
               endif
            enddo
*           here we know that val(j1) <= X(i) <= val(j2)  with j2 = j1 + 1
*           (in fact we have exactly  val(j1) <= X(i) < val(j2) if j2 < n)
            if (X(i) .eq. val(j1)) then
               occ(j1) = occ(j1) + 1
               indX(i) = j1
            else if (X(i) .eq. val(j2)) then  ! (note: this case may happen only for j2=n)
               occ(j2) = occ(j2) + 1
               indX(i) = j2
            else  ! X(i) is not in {val(1), val(2),..., val(n)}
               info = info + 1
               indX(i) = 0
            endif
         else     ! X(i) is not in {val(1), val(2),..., val(n)}
            info = info + 1
            indX(i) = 0
         endif
      enddo

      end


PROGRAM PE2D_HT_FD
 USE PE2D_TYPE
 USE PE2D_VAR
 USE PE2D_AUX
 USE PE2D_GROUND
 IMPLICIT NONE
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) "========== Parabolic Equation Package =========="
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "University of Bristol"
 WRITE(*,*) "Mech. Eng. Department"
 WRITE(*,*) "Aerodynamics and Aeroacoustics Research Group"
 WRITE(*,*) ""
 WRITE(*,*) "Codor Khodr, July 2016"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "PE2D_HFR"
 WRITE(*,*) "Dimension  :  2D"
 WRITE(*,*) "Atmosphere : Homogeneous"
 WRITE(*,*) "Boundary  : Flat"
 WRITE(*,*) "Impedance : Rigid"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Enter inputs L, f, zs, As, angle"
 WRITE(*,*) ""
 READ *, L, F, ZS, ABL, ANGLE
 WRITE(*,*) ""
 WRITE(*,*) "Store output ? (Y or N)"
 WRITE(*,*) ""
 READ *, OUTPUT
 !-----------------------------------------------------------
 !----------------------------------------------------------
 C0 = 343.0_DP
 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 steps : ", M
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 NS = MAX(1,FLOOR(ZS/DZ))
 NABL = FLOOR(HABL/DZ)
 A = IM/(2.0_DP*K0*DZ**2)
 KU = 1
 KL = 1
 NDIAG = KU+KL+1
 WIDE = 0
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !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), I(N,N), P(N,M), LP(N,M), LP2(N,M), LPG(M), LPG2(M), E(N,N), &
 MB2(NDIAG,N), MB1(NDIAG,N), TEMP(N,1), M1T(N,N), M2T(N,N), IPIV(N), &
 TERR(-1:M+2), TERR1(-1:M+2), TERR2(-1:M+2), LIN(-2:M+2), GHX(3), MCOND(M,2), &
 MB1T(NDIAG,N), MB2T(KL+NDIAG,N), X(-1:M+2))
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Atmosphere density and wave velocity
 DO NZ = 1,N
  IF (NZ.GE.(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.0_DP/(3.0_DP-2.0_DP*IM*K0*DZ)
 TAU2 = -1.0_DP/(3.0_DP-2.0_DP*IM*K0*DZ)
 SIGMA1 = 4.0_DP/3.0_DP
 SIGMA2 = -1.0_DP/3.0_DP
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Terrain Boundary condition
 LIN(-2) = 0
 THETA = ANGLE*PI/180.0_DP
 X0 = L/2.0_DP
 S = L/5.0_DP
 H0 = SQRT(EXP(1.0_DP)/2.0_DP)*S*ATAN(THETA)
 DO MX = -1,M+2
  GHX = GHILL(H0,X0,S,MX*DR)
  TERR(MX) = GHX(1)
  !TERR1(MX) = GHX(2)
  !TERR2(MX) = GHX(3)
  X(MX) = MX*DR
  LIN(MX) = LIN(MX-1)+(1+TERR1(MX))*DR
 END DO
 TERR1 = DIFF1(X,TERR)
 TERR2 = DIFF2(X,TERR)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Starting field
 A0 = 1.3717_DP
 A2 = -0.3701_DP
 B = 3.0_DP
 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, D and E
 !---------
 T(:,:) = 0.0_DP
 DO NZ = 2,N-1
  T(NZ,NZ-1) = 1.0_DP
  T(NZ,NZ) = -2.0_DP
  T(NZ,NZ+1) = 1.0_DP
 END DO
 T(1,1) = -2.0_DP+SIGMA1
 T(1,2) = 1.0_DP+SIGMA2
 T(N,N-1) = 1.0_DP+TAU2
 T(N,N) = -2.0_DP+TAU1
 E = DIAG(ALT,N)
 D = DIAG(DK2,N)
 I = EYE(N)
 !-----------------------------------------------------------
 !System - M1 and M2
 !---------
 ALPHA = CMPLX(1.0_DP,0.0_DP,KIND=DP)
 BETA = CMPLX(0.0_DP,0.0_DP,KIND=DP)
 SELECT CASE (WIDE)
  CASE(0)
   BETA1 = DR/2.0_DP
   BETA2 = -DR/2.0_DP
  CASE(1)
   BETA1 = 1.0_DP/(2.0_DP*IM*K0)+DR/2.0_DP
   BETA2 = 1.0_DP/(2.0_DP*IM*K0)-DR/2.0_DP
  CASE DEFAULT
   STOP "[MAIN] : Enter valid wide-angle case"
 END SELECT
 WRITE(*,*) "Wide-angle order : ", WIDE
 M1 = I+A*BETA1*T+BETA1*D
 M2 = I+A*BETA2*T+BETA2*D
 MB1 = DENSE2BAND(M1,N,KL,KU)
 MB2 = DENSE2BAND(M2,N,KL,KU)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Forward-marching procedure
 CALL CPU_TIME(TI)
 !-----------------------------------------------------------
 DO MX = 2,M+1
  WRITE(*,*) "Step :", MX-1, "out of", M
  !-------------------------------
  !Matrix updating
  !-------------------------------
  !TERR1(MX-1) = (TERR(MX)-TERR(MX-1))/DR
  !TERR2(MX-1) = (TERR1(MX)-TERR1(MX-1))/DR       !Varying coefficient to be injected...
  MB1T = MB1
  MB1T(KU+1,:) = MB1(KU+1,:)-BETA1*IM*K0*TERR2(MX-1)*ALT
  MB2T(KL+1:KL+NDIAG,:) = MB2
  MB2T(KL+KU+1,:) = MB2(KU+1,:)-BETA2*IM*K0*TERR2(MX-1)*ALT
  !-------------------------------
  !Right hand side multiplication
  !-------------------------------
  CALL ZGBMV('N',N,N,KL,KU,ALPHA,MB1T,KL+KU+1,PHI(1:N,MX-1),1,BETA,TEMP(:,1),1)
  WRITE(*,*) ".... Right-hand side multiplied"
  !-------------------------------
  !System solving
  !-------------------------------
  !MTEMP2 = M2
  !CALL ZGESV(N,1,M2T,N,IPIV,TEMP,N,INFO)                                                         !General matrix form
  CALL ZGBSV(N,KL,KU,1,MB2T,2*KL+KU+1,IPIV,TEMP,N,INFO)                                           !Band matrix form
  !CALL ZGTSV(N,1,MT2T(3,1:N-1),MT2T(2,1:N),MT2T(1,2:N),TEMP(:,1),N,INFO)                         !Tridiagonal matrix form
  IF (INFO.NE.0) THEN
   STOP "ERROR : Matrix is singular"
  END IF
  WRITE(*,*) ".... System solved"
  PHI(1:N,MX) = TEMP(:,1)
  P(1:N,MX-1) = EXP(IM*K0*(MX-1)*DR)*PHI(1:N,MX)/SQRT((MX-1)*DR)
  WRITE(*,*)
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 CALL CPU_TIME(TF)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Transmission loss conversion
 P0 = ABS(P(NS,1))
 DO MX = 1,M
  DO NZ = 1,N
   LP(NZ,MX) = 20.*LOG10(ABS(P(NZ,MX))/P0)
   IF (LP(NZ,MX).LE.-120) THEN
    LP(NZ,MX) = -120
   END IF
  END DO
 END DO
 LPG = LP(1,1:M)
 LP2 = LP/SQRT(2.0_DP)
 LPG2 = LP2(1,1:M)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 IF (OUTPUT.EQ."Y") THEN
 !Output
  OPEN(UNIT=10,FILE="../results/Topo_LPg.dat")
  OPEN(UNIT=20,FILE="../results/Topo_LP.dat")
  OPEN(UNIT=30,FILE="../results/Topo_P.dat")
  OPEN(UNIT=50,FILE="../results/Topo.dat")
  DO MX = 1,M
   WRITE(10,100) MX*DR, LPG(MX), LPG2(MX)
   WRITE(50,100) MX*DR, TERR(MX), TERR1(MX), TERR2(MX)
   DO NZ = 1,N
    WRITE(20,100) MX*DR, NZ*DZ+TERR(MX), LP(NZ,MX)
    WRITE(30,101) MX*DR, NZ*DZ+TERR(MX), ABS(P(NZ,MX))
   END DO
   WRITE(20,*)
   WRITE(30,*)
  END DO
  100 FORMAT(3(3X,F12.3))
  101 FORMAT(2(3X,F12.3),3X,F12.3,SP,F12.3,SS,"i")
  !Plotting of results
  CALL SYSTEM('gnuplot -p plot_topo.plt')
  CALL SYSTEM('gnuplot -p plot_topo2.plt')
 END IF
 PRINT *, "Main CPU time (s) :", TF-TI
 PRINT *, "Source pressure P0 (dB) :", 20*LOG10(ABS(P0))
 !-----------------------------------------------------------
 !----------------------------------------------------------
END PROGRAM PE2D_HT_FD
!-----------------------------------------------------------
!-------------      EXTERNAL PROCEDURES      ---------------
!-----------------------------------------------------------


function func(i) result(j)
    integer, intent(in) :: i ! input
    integer             :: j ! output
    integer, dimension (5,5) :: matrix
    j = i**2 + i**3
end function func

program xfunc
    implicit none
    integer :: i
    integer :: func
    i = 3
    print*,"sum of the square and cube of",i," is",func(i)
 end program xfunc


!
! Note: This isn't intended to be a comprehensive PRNG test suite, but is
! merely intended to highlight any serious flaws in the coding rather than
! numerical design.
!
program random
   use spral_random
   implicit none

   integer, parameter :: long = selected_int_kind(18)
   integer, parameter :: wp = kind(0d0)

   integer, parameter :: nsamples = 50000
   integer, parameter :: nbins = 100
   real, parameter :: require_confidence = 0.99

   integer :: errors

   errors = 0

   call test_real_dist()
   call test_integer32_dist()
   call test_integer64_dist()
   call test_logical_dist()

   if(errors.eq.0) then
      write(*, "(/a)") "==================="
      write(*, "(a)") "All tests suceeeded"
      write(*, "(a)") "==================="
   else
      write(*, "(/a)") "==================="
      write(*, "(a, i4)") "Failed ", errors
      write(*, "(a)") "==================="
   endif

contains

subroutine test_real_dist
   type(random_state) :: state

   integer :: i, j
   integer :: bin(nbins)
   real(wp) :: sample, chisq

   write(*, "(/a)") "====================================="
   write(*, "(a)") "Testing random_real()"
   write(*, "(a)") "====================================="

   !
   ! Test (-1,1) distribution
   !
   write(*, "(a)", advance="no") "Sampling Unif(-1,1)...... "
   ! Acquire sample
   bin(:) = 0
   do i = 1, nsamples
      sample = random_real(state)
      j = int(nbins * ((sample+1.0_wp)/2.0_wp)) + 1
      bin(j) = bin(j) + 1
   end do
   chisq = 1.0_wp/nsamples * sum( (bin(:)**2.0_wp) * nbins ) - nsamples
   if(chisq < chisq_pval(nbins-1, require_confidence)) then
      write(*, "(a)") "pass"
   else
      write(*, "(a)") "fail"
      write(*, "(a,es12.4)") "chisq statistic = ", chisq
      write(*, "(a,es12.4)") "chisq required  < ", &
         chisq_pval(nbins-1, require_confidence)
      errors = errors + 1
   endif

   !
   ! Test (0,1) distribution
   !
   write(*, "(a)", advance="no") "Sampling Unif(0,1)....... "
   ! Acquire sample
   bin(:) = 0
   do i = 1, nsamples
      sample = random_real(state, positive=.true.)
      j = int(nbins * sample) + 1
      bin(j) = bin(j) + 1
   end do
   chisq = 1.0_wp/nsamples * sum( (bin(:)**2.0_wp) * nbins ) - nsamples
   if(chisq < chisq_pval(nbins-1, require_confidence)) then
      write(*, "(a)") "pass"
   else
      write(*, "(a)") "fail"
      write(*, "(a,es12.4)") "chisq statistic = ", chisq
      write(*, "(a,es12.4)") "chisq required  < ", &
         chisq_pval(nbins-1, require_confidence)
      errors = errors + 1
   endif

end subroutine test_real_dist

subroutine test_integer32_dist
   type(random_state) :: state

   integer :: i
   integer :: bin(nbins)
   real(wp) :: chisq
   integer :: sample

   write(*, "(/a)") "====================================="
   write(*, "(a)") "Testing random_integer() 32-bit"
   write(*, "(a)") "====================================="

   !
   ! Test (1,...,n) distribution
   !
   write(*, "(a)", advance="no") "Sampling Unif(1,...,n)... "
   ! Acquire sample
   bin(:) = 0
   do i = 1, nsamples
      sample = random_integer(state,nbins)
      bin(sample) = bin(sample) + 1
   end do
   chisq = 1.0_wp/nsamples * sum( (bin(:)**2.0_wp) * nbins ) - nsamples
   if(chisq < chisq_pval(nbins-1, require_confidence)) then
      write(*, "(a)") "pass"
   else
      write(*, "(a)") "fail"
      write(*, "(a,es12.4)") "chisq statistic = ", chisq
      write(*, "(a,es12.4)") "chisq required  < ", &
         chisq_pval(nbins-1, require_confidence)
      errors = errors + 1
   endif
end subroutine test_integer32_dist

subroutine test_integer64_dist
   type(random_state) :: state

   integer :: i
   integer :: bin(nbins)
   real(wp) :: chisq
   integer(long) :: sample

   write(*, "(/a)") "====================================="
   write(*, "(a)") "Testing random_integer() 64-bit"
   write(*, "(a)") "====================================="

   !
   ! Test (1,...,n) distribution
   !
   write(*, "(a)", advance="no") "Sampling Unif(1,...,n)... "
   ! Acquire sample
   bin(:) = 0
   do i = 1, nsamples
      sample = random_integer(state,int(nbins,long))
      bin(sample) = bin(sample) + 1
   end do
   chisq = 1.0_wp/nsamples * sum( (bin(:)**2.0_wp) * nbins ) - nsamples
   if(chisq < chisq_pval(nbins-1, require_confidence)) then
      write(*, "(a)") "pass"
   else
      write(*, "(a)") "fail"
      write(*, "(a,es12.4)") "chisq statistic = ", chisq
      write(*, "(a,es12.4)") "chisq required  < ", &
         chisq_pval(nbins-1, require_confidence)
      errors = errors + 1
   endif
end subroutine test_integer64_dist

subroutine test_logical_dist
   type(random_state) :: state

   integer :: i, j
   integer :: bin(2)
   real(wp) :: chisq
   logical :: sample

   write(*, "(/a)") "====================================="
   write(*, "(a)") "Testing random_logical()"
   write(*, "(a)") "====================================="

   !
   ! Test (1,...,n) distribution
   !
   write(*, "(a)", advance="no") "Sampling B(1,0.5)........ "
   ! Acquire sample
   bin(:) = 0
   do i = 1, nsamples
      sample = random_logical(state)
      if(sample) then
         j = 1
      else
         j = 2
      endif
      bin(j) = bin(j) + 1
   end do
   chisq = 1.0_wp/nsamples * sum( (bin(:)**2.0_wp) * 2 ) - nsamples
   if(chisq < chisq_pval(1, require_confidence)) then
      write(*, "(a)") "pass"
   else
      write(*, "(a)") "fail"
      write(*, "(a,es12.4)") "chisq statistic = ", chisq
      write(*, "(a,es12.4)") "chisq required  < ", &
         chisq_pval(1, require_confidence)
      errors = errors + 1
   endif

end subroutine test_logical_dist

real(wp) function chisq_pval(dof, p)
   integer, intent(in) :: dof
   real, intent(in) :: p

   real(wp) :: xp

   if(p.eq.0.99) then
      xp = 2.33
   else
      write(*, "(a)") "Uncoded pval for chisq_pval"
      stop
   endif

   chisq_pval = dof + sqrt(2.0_wp*dof)*xp + (2*xp**2)/3 - 2/3.0_wp
end function chisq_pval

end program random


MODULE monotonicMod

! tests whether an input vector is strictly monotonically increasing
!
! mbp February 2014

  IMPLICIT NONE

  INTERFACE monotonic
     MODULE PROCEDURE monotonic_sngl, monotonic_dble
  END INTERFACE monotonic

CONTAINS
  FUNCTION monotonic_sngl( x, N )
    LOGICAL :: monotonic_sngl
    INTEGER,                       INTENT( IN ) :: N
    REAL (KIND=4), DIMENSION( N ), INTENT( IN ) :: x

    monotonic_sngl = .TRUE.
    IF ( N == 1 ) RETURN
    IF ( ANY( x( 2 : N ) <= x( 1 : N - 1 ) ) ) monotonic_sngl = .FALSE.

  END FUNCTION monotonic_sngl

  FUNCTION monotonic_dble( x, N )
    LOGICAL :: monotonic_dble
    INTEGER,                       INTENT( IN ) :: N
    REAL (KIND=8), DIMENSION( N ), INTENT( IN ) :: x

    monotonic_dble = .TRUE.
    IF ( N == 1 ) RETURN
    IF ( ANY( x( 2 : N ) <= x( 1 : N - 1 ) ) ) monotonic_dble = .FALSE.

  END FUNCTION monotonic_dble
END MODULE monotonicMod


subroutine axpy(n, a, X, Y, Z)
use iso_fortran_env, only: real64
implicit none
integer :: n
real(real64) :: a
real(real64) :: X(*), Y(*), Z(*)
integer :: i

  do i = 1, n
    Z(i) = a * X(i) + Y(i)
  end do

end subroutine axpy

program axpyProg
use iso_fortran_env, only: real64
implicit none
real(real64) :: a
real(real64), allocatable :: X(:), Y(:), Z(:)
integer :: n

  n = 2**10

  allocate(X(n))
  allocate(Y(n))
  allocate(Z(n))

  call random_seed
  call random_number(a)
  call random_number(X)
  call random_number(Y)

  call axpy(n, a, X, Y, Z)

  print *, maxval(abs(Z)), maxval(abs(Z / (a * X + Y) - 1.0_real64))

  deallocate(X)
  deallocate(Y)
  deallocate(Z)

end program axpyProg


        PROGRAM MAIN

        IMPLICIT NONE
        REAL EPS
        EPS=1.0
        DO WHILE (1.0+EPS.GT.1.0)
            EPS=EPS/2.0
        END DO
        EPS=EPS*2

        PRINT *, EPS

        END PROGRAM MAIN


module rational_numbers
  implicit none
  private
  type, public :: rational
     private
     integer n, d
   contains
     ! ordinary type-bound procedure
     procedure :: real => rat_to_real
     ! specific type-bound procedures for generic support
     procedure, private :: rat_asgn_i, rat_plus_rat, rat_plus_i
     procedure, private, pass(b) :: i_plus_rat
     ! generic type-bound procedures
     generic :: assignment(=) => rat_asgn_i
     generic :: operator(+) => rat_plus_rat, rat_plus_i, i_plus_rat
  end type rational
contains
  elemental real function rat_to_real(this) result(r)
    class(rational), intent(in) :: this
    r = real(this%n)/this%d
  end function rat_to_real
  elemental subroutine rat_asgn_i(a,b)
    class(rational), intent(out) :: a
    integer, intent(in) :: b
    a%n = b
    a%d = 1
  end subroutine rat_asgn_i
  elemental type(rational) function rat_plus_i(a,b) result(r)
    class(rational), intent(in) :: a
    integer,intent(in) :: b
    r%n = a%n + b*a%d
    r%d = a%d
  end function rat_plus_i
  elemental type(rational) function i_plus_rat(a,b) result(r)
    integer,intent(in) :: a
    class(rational),intent(in) :: b
    r%n = b%n + a*b%d
    r%d = b%d
  end function i_plus_rat
  elemental type(rational) function rat_plus_rat(a,b) result(r)
    class(rational),intent(in) :: a,b
    r%n = a%n*b%d + b%n*a%d
    r%d = a%d*b%d
  end function rat_plus_rat
end


SUBROUTINE CGELSD_F95( A, B, RANK, S, RCOND, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
      USE LA_PRECISION, ONLY: WP => SP
      USE LA_AUXMOD, ONLY: ERINFO
      USE F77_LAPACK, ONLY: GELSD_F77 => LA_GELSD,  ILAENV_F77 => ILAENV
!   .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
      INTEGER, INTENT(OUT), OPTIONAL :: RANK
      INTEGER, INTENT(OUT), OPTIONAL :: INFO
      REAL(WP), INTENT(IN), OPTIONAL :: RCOND
!   .. ARRAY ARGUMENTS ..
      COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:)
      REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: S(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!       LA_GELSS and LA_GELSD compute the minimum-norm least squares
! solution to one or more real or complex linear systems A*x = b using
! the singular value decomposition of A. Matrix A is rectangular and may
! be rank-deficient. The vectors b and corresponding solution vectors x
! are the columns of matrices denoted B and X , respectively.
!       The effective rank of A is determined by treating as zero those
! singular values which are less than RCOND times the largest singular
! value. In addition to X , the routines also return the right singular
! vectors and, optionally, the rank and singular values of A.
!       LA_GELSD combines the singular value decomposition with a divide
! and conquer technique. For large matrices it is often much faster than
! LA_GELSS but uses more workspace.
!
! ==========
!
!        SUBROUTINE LA_GELSS / LA_GELSD( A, B, RANK=rank, S=s, &
!                                          RCOND=rcond, INFO=info )
!             <type>(<wp>), INTENT( INOUT ) :: A( :, : ), <rhs>
!             INTEGER, INTENT(OUT), OPTIONAL :: RANK
!             REAL(<wp>), INTENT(OUT), OPTIONAL :: S(:)
!             REAL(<wp>), INTENT(IN), OPTIONAL :: RCOND
!             INTEGER, INTENT(OUT), OPTIONAL :: INFO
!        where
!             <type> ::= REAL | COMPLEX
!             <wp>   ::= KIND(1.0) | KIND(1.0D0)
!             <rhs>  ::= B(:,:) | B(:)
!
! Arguments
! =========
!
! A       (input/output) REAL or COMPLEX array, shape (:,:).
!         On entry, the matrix A.
!         On exit, the first min(size(A,1), size(A,2)) rows of A are
!         overwritten with its right singular vectors, stored rowwise.
! B       (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(B,1) = max(size(A,1), size(A,2)) or shape (:) with
!         size(B) = max(size(A,1), size(A,2)).
!         On entry, the matrix B.
!         On exit, the solution matrix X .
!         If size(A,1) >= size(A,2) and RANK = size(A,2), the residual
!         sum-of-squares for the solution in a column of B is given by
!         the sum of squares of elements in rows size(A,2)+1:size(A,1)
!         of that column.
! RANK    Optional (output) INTEGER.
!         The effective rank of A, i.e., the number of singular values
!         of A which are greater than the product RCOND*sigma1 , where
!  	  sigma1 is the greatest singular value.
! S       Optional (output) REAL array, shape (:) with size(S) =
!         min(size(A,1), size(A,2)).
!         The singular values of A in decreasing order.
!         The condition number of A in the 2-norm is
! 	  K2(A)= sigma1/sigma(min(size(A,1),size(A,2)) .
! RCOND   Optional (input) REAL.
!         RCOND is used to determine the effective rank of A.
!         Singular values sigma(i)<=RCOND*sigma1  are treated as zero.
!         Default value: 10*max(size(A,1), size(A,2))*EPSILON(1.0_<wp>),
!         where <wp> is the working precision.
! INFO    Optional (output) INTEGER.
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         > 0: the algorithm for computing the SVD failed to converge;
! 	  if INFO = i,i off-diagonal elements of an intermediate
! 	  bidiagonal form did not converge to zero.
!         If INFO is not present and an error occurs, then the program
! 	  is terminated with an error message.
!----------------------------------------------------------------------
!   .. PARAMETERS ..
      CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GELSD'
!   .. LOCAL SCALARS ..
      INTEGER :: LINFO, ISTAT, LWORK, N, M, MN, NRHS, LRANK, SS, &
     &  LIWORK, SMLSIZ, NLVL, LRWORK
      REAL(WP) :: LRCOND
!   .. LOCAL POINTERS ..
      COMPLEX(WP), POINTER :: WORK(:)
      REAL(WP), POINTER :: LS(:)
      INTEGER, POINTER :: IWORK(:)
      REAL(WP), POINTER :: RWORK(:)
      COMPLEX(WP) :: WORKMIN(1)
      INTEGER :: IWORKMIN(1)
      DOUBLE PRECISION  TWO
      PARAMETER       ( TWO = 2.0D0 )
!   .. INTRINSIC FUNCTIONS ..
      INTRINSIC SIZE, PRESENT, MAX, MIN, EPSILON
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; ISTAT = 0; M = SIZE(A,1); N = SIZE(A,2); NRHS = SIZE(B,2)
    MN = MIN(M,N)
       SMLSIZ = ILAENV_F77( 9, 'ZGELSD', ' ', 0, 0, 0, 0 )
       NLVL = MAX(INT(LOG(DBLE(MAX(1,MN))/DBLE(SMLSIZ+1))/LOG(TWO)),0)
! NEXT LINE SHOULD BE  LIWORK = 3 * MN * NLVL + 11 * MN, WHEN THE LAPACK CODE IS FIXED
       LIWORK = 2*(3 * MN * NLVL + 11 * MN)
       LRWORK = 8  * MN + 2*MN*SMLSIZ + 8*MN*NLVL + MN*NRHS

       LRWORK = 25000
       ALLOCATE(RWORK(LRWORK), STAT = ISTAT)
       IF (ISTAT /= 0) THEN ; LINFO=-100; GOTO 100; ENDIF

       IF( PRESENT(RCOND) )THEN; LRCOND = RCOND
       ELSE; LRCOND = 100*EPSILON(1.0_WP); ENDIF
       IF( PRESENT(S) )THEN; SS = SIZE(S); ELSE; SS =MN; ENDIF
!   .. TEST THE ARGUMENTS
       IF( M < 0 .OR. N < 0 ) THEN; LINFO = -1
       ELSE IF( SIZE( B, 1 ) /= MAX(1,M,N) .OR. NRHS < 0 ) THEN; LINFO = -2
       ELSE IF( SS /= MN ) THEN; LINFO = -4
       ELSE IF( LRCOND <= 0.0_WP ) THEN; LINFO = -5
       ELSE
          IF( PRESENT(S) )THEN; LS => S
          ELSE
            ALLOCATE( LS(MN), STAT = ISTAT );
            IF (ISTAT /= 0) THEN ;
             LINFO=-200; GOTO 200; ENDIF
          END IF
          LWORK=-1

          CALL GELSD_F77( M, N, NRHS, A, MAX(1,M), B, MAX(1,M,N), &
     &         LS, LRCOND, LRANK, WORKMIN, LWORK, RWORK, IWORKMIN, LINFO )
          LWORK = WORKMIN(1)
! THE NEXT LINE SHOULD BE REMOVED, WHEN THE LAPACK CODE IS FIXED.
          LWORK = 10 * LWORK
          ALLOCATE( WORK(LWORK), IWORK(LIWORK), STAT = ISTAT )
          IF (ISTAT /= 0) THEN;
	    LINFO=-300; GOTO 300
          ENDIF

          CALL GELSD_F77( M, N, NRHS, A, MAX(1,M), B, SIZE(B,1), &
     &      LS, LRCOND, LRANK, WORK, LWORK, RWORK, IWORK, LINFO )

          IF( PRESENT(RANK) ) RANK = LRANK
          DEALLOCATE(WORK, IWORK, STAT = ISTAT)
300       IF (.NOT. PRESENT(S)) DEALLOCATE(LS, STAT = ISTAT)
        END IF
200     DEALLOCATE(RWORK, STAT = ISTAT)
100     CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE CGELSD_F95