c--------------------------------------------------------
c  This program uses a semi-implicit representation of
c  the nonlinearities along with up- and down- winding
c  in regions where \psi_y=u is +ve or -ve respectively
c  The flow is periodic in x and also odd about x=pi
c  The latter condition is enforced in the finite-differences.
c  2nd order upwind and downwind formulas are used.
c--------------------------------------------------------
c
c   NOTE that the BC here psi_\eta = - sin(x)
c   BUT THIS TIME GURSH HAS FORCED THE ODD SOLUTION
c   WITH APPROPRIATE BOUNDARY CONDITIONS AT THE ORIGIN
c----------------------------------------------------------
c  Gursh-Edited the code to make memory consumption minimal via
c  introducing INX and INN

      implicit double precision(a-h,o-y)
      implicit complex*16(z)
      integer INX, INN
      parameter(INX=265,INN=56)

      complex*16 px(INX),pxd(INX),wsave(4*1600+15)

      dimension a(INN),b(INN),c(INN),d(INN),e(INN)
      dimension r(INN),x(INN),y(INN),u(INN),v(INN),xx(INX)
      dimension psi(INX,0:INN),psi1(INX,0:INN),shp(INX)
     $,up(3),uq(3),psix(INX,0:INN),zvhp(INX),zuhp(INX),
     $uhm(INX),vhm(INX),uhp(INX),vhp(INX),uh0(INX),vh0(INX)

      open(1,file='input',status='old')
      open(11,file='final',status='unknown')
      open(112,file='psifin.m',status='unknown')
      open(2,file='en.m',status='unknown')
      open(34,file='sum.m',status='unknown')
      open(3,file='u1.m',status='unknown')
      open(4,file='u2.m',status='unknown')
      open(7,file='u3.m',status='unknown')
      open(8,file='v1.m',status='unknown')
      open(9,file='v2.m',status='unknown')
      open(10,file='v3.m',status='unknown')
      open(14,file='v0.m',status='unknown')
      open(13,file='vpi.m',status='unknown')
      open(15,file='maxm.m',status='unknown')
      open(16,file='minm.m',status='unknown')
      open(17,file='maxp.m',status='unknown')
      open(18,file='minp.m',status='unknown')
      open(30,file='uhm.m',status='unknown')
      open(31,file='vhm.m',status='unknown')
      open(32,file='uhp.m',status='unknown')
      open(33,file='vhp.m',status='unknown')
      open(34,file='uh0.m',status='unknown')
      open(35,file='vh0.m',status='unknown')
      open(36,file='specvp.m',status='unknown')
      open(37,file='specup.m',status='unknown')
      open(38,file='shearp.m',status='unknown')
      open(39,file='shtime.m',status='unknown')
      open(40,file='psi.m',status='unknown')

      read(1,*) n
      read(1,*) nx
      read(1,*) dt
      read(1,*) nmax
      read(1,*) rm
      read(1,*) tmax
      read(1,*) tstart
      read(1,*) papstart
      read(1,*) nstore
      read(1,*) nwrite
      read(1,*) icont
      read(1,*) iphase
      read(1,*) ipap

      write(6,*) n,nx,dt,nmax,rm,tmax,tstart,papstart,nstore
      write(6,*) nwrite,icont,iphase,ipap
      if((dt*nmax).lt.tmax) then
      write(6,*) 'Increase nmax'
      write(6,*) 'Otherwise run will finish at t==',(dt*nmax)
      write(6,*) 'Which is less than Tmax =',tmax
      endif

      tout1=50.0
      tout2=100.0
      tout3=200.0
      tout4=300.0
      tout5=400.0

c-----computational parameters-------------------------------
c  h=step in the y-direction
c  dx=step in the x-direction
c  (n+1) points in the y-direction
c  (nx+1) points in the x-direction

      if((INN.lt.(n+5)).or.(inx.lt.(nx+5))) then
      write(6,*) 'INN/INX too small in code -increase them'
      end if

c     change value of h
      h=1.d0/float(n+1)
      h2=h**2
      h3=h**3
      h4=h**4
      api=4.d0*datan(1.d0)
      dx=2.d0*api/float(nx)
      aa1=DBLE(dt/(rm*h*h))
      aa2=dt/(4.*h*dx)
      aw=-1.d0
      bw=-1.d0
      nx1=nx/8
      nx2=nx/4
      nx3=3*nx/8
      nm=1+(n+1)/4
      np=1+3*(n+1)/4
      n0=1+(n+1)/2
      ixp=10
      nspec=1/dt

      tol=1.d-8

      zi=dcmplx(0.d0,1.d0)

      call CFFTI(nx,wsave)

c------------------------------------------------------------
c1234 continue
      if(icont.eq.1) goto 88

c--- Set up initial conditions --------------------------------
      t=0.d0
 3    continue
      do 19 i=1,nx
      xx(i)=dx*(i-1)
      do 1 j=1,n+2
      y(j)=-1.d0+h*(j-1)
c1    psi(i,j)=0.
c 1    psi(i,j)=.5d0*(y(j)-y(j)*y(j)*y(j))*sin(xx(i))
      psi(i,j)=sin(api*y(j))*sin(xx(i))/api
 1    continue
 19   continue
      do 44 i=1,nx
c     change value derivative
      psi(i,0)=psi(i,2)-2.d0*h*aw*sin(dx*(i-1))
      psi(i,n+3)=-psi(i,n+1)
c      psi(i,n+3)=psi(i,n+1)+2.d0*h*bw*sin(dx*(i-1))
      psi(i,1)=0.d0
      psi(i,n+2)=0.d0
 44   continue
      goto 89
c-------------------------------------------------------------

c-- the following are the read initial conditions for continuation
 88   read(11,*) t
      do 656 j=0,n+3
      read(40,1024) (psi(i,j),i=1,nx)
 656  continue
c---------------------------------------------------------------

  89  continue

c---Time loop ---------------------------------------------------

      do 4 iu=1,nmax

c--- set up psix(i,j) the derivative psi_x, pseudospectrally

      do 350 j=2,n+1

      do 351 i=1,nx
      px(i)=cmplx(psi(i,j),0.)
 351     continue

      CALL CFFTF(nx,px,wsave)

      if((mod(iu,nstore).eq.0).and.(ipap.eq.1).and.(t.gt.papstart).
     # and.(j.eq.nm)) then
      write(6,*) 'FM 1-5, last',px(1),px(2),px(3),px(4),px(5),px(nx/2)
      endif

c---- filter out even components and high spectral modes --------
      px(1)=0.d0
      do 357 i=2,nx
      px(i)=dcmplx(0.d0,dimag(px(i)))
 357  continue

      do 352 i=1,nx/2
      fac=dble(i)/dble(nx/2)
      if(abs(dimag(px(i))).lt.(10**(-8))) px(i)=0.
       pxd(i)=zi*dble(i-1)*px(i)
352   continue
      do 353 i=nx/2+1,nx
      fac=dble(nx+1-i)/dble(nx/2)
      if(abs(dimag(px(i))).lt.(10**(-8))) px(i)=0.
      pxd(i)=zi*dble(i-nx-1)*px(i)
 353  continue
      pxd(nx/2+1)=0.d0

      CALL CFFTB(nx,pxd,wsave)

      do 354 i=1,nx
      psix(i,j)=dble(pxd(i))/dble(nx)
 354  continue

 350  continue

      do 355 i=1,nx
      psix(i,1)=0.d0
      psix(i,n+2)=0.d0
 355  continue

c---  psix(i,j) is a real valued array equal to psi_x

      do 55 ix=1,nx

c---- loop in y-direction   ii=2,n+1  (y=-1+h, 1-h)

      do 2 ii=2,n+1

         i=ii-1
         a(i)=-.5d0*aa1
         b(i)=1.d0+2.d0*aa1
         c(i)=-2.d0-3.d0*aa1
         d(i)=1.d0+2.d0*aa1
         e(i)=-.5d0*aa1

      r(i)=psi(ix,ii+1)-2.d0*psi(ix,ii)+
     #      psi(ix,ii-1)+.5d0*aa1*(psi(ix,ii+2)
     #     -4.d0*psi(ix,ii+1)+6.d0*psi(ix,ii)
     #     -4.d0*psi(ix,ii-1)+psi(ix,ii-2))
     #     +.5d0*(dt/h)*(
     #      psix(ix,ii)*(psi(ix,ii+2)-2.d0*psi(ix,ii+1)
     #      +2.d0*psi(ix,ii-1)-psi(ix,ii-2))
     #     -(psi(ix,ii+1)-psi(ix,ii-1))
     #     *(psix(ix,ii+1)-2.d0*psix(ix,ii)
     #       +psix(ix,ii-1))
     #     )

 2    continue
c     change LU matrix and RHS vector
      c(1)=c(1)+a(1)
      c(n)=c(n)-e(n)
      r(1)=r(1)+2.d0*h*aw*a(1)*sin((ix-1)*dx)
      r(n)=r(n)
c----------------------------------------------------------------
c     This is the inversion procedure for the matrix with
c     columns a b c d with RHS vector r

      D(1)=D(1)/C(1)
      E(1)=E(1)/C(1)
      r(1)=r(1)/C(1)
      C(2)=C(2)-B(2)*D(1)
      D(2)=(D(2)-B(2)*E(1))/C(2)
      r(2)=(r(2)-B(2)*r(1))/C(2)
      E(2)=E(2)/C(2)
      DO 7 I=3,N
      B(I)=B(I)-A(I)*D(I-2)
      C(I)=C(I)-A(I)*E(I-2)
      r(I)=r(I)-A(I)*r(I-2)
      C(I)=C(I)-B(I)*D(I-1)
      D(I)=(D(I)-B(I)*E(I-1))/C(I)
      E(I)=E(I)/C(I)
      r(I)=(r(I)-B(I)*r(I-1))/C(I)
  7   continue
      X(N)=r(N)
      X(N-1)=r(N-1)-D(N-1)*X(N)
      NM1=N-2
      DO 8 I=1,NM1
      K=N-I-1
      X(K)=r(K)-D(K)*X(K+1)-E(K)*X(K+2)
 8    CONTINUE

      do 444 i=2,n+1
      psi1(ix,i)=x(i-1)
 444  continue

c     change Solution update after inversion
      psi1(ix,0)=psi1(ix,2)-2.d0*h*aw*sin(dx*(ix-1))
      psi1(ix,n+3)=-psi1(ix,n+1)
      psi1(ix,1)=0.d0
      psi1(ix,n+2)=0.d0

 55   continue
      t=t+dt
      do 555 i=1,nx
      do 556 j=0,n+3
      psi(i,j)=psi1(i,j)
556   continue
 555  continue

      if((mod(iu,nstore).eq.0).and.(ipap.eq.1).and.(t.gt.papstart)) then
      sum=0.d0
      sum1=0.d0
      sum2=0.d0
      sum3=0.d0
      sum0=0.d0
      do 77 i=2,n+1
      v0=-psix(1,i)
      vpi=-psix(nx/2,i)
      u1=(psi(nx1,i+1)-psi(nx1,i-1))/2.d0/h
      v1=-psix(nx1+1,i)
      u2=(psi(nx2,i+1)-psi(nx2,i-1))/2.d0/h
      v2=-psix(nx2+1,i)
      u3=(psi(nx3,i+1)-psi(nx3,i-1))/2.d0/h
      v3=-psix(nx3+1,i)
      sum0=sum0+h*v0*v0
      sum=sum+h*vpi*vpi
      sum1=sum1+h*(u1*u1+v1*v1)
      sum2=sum2+h*(u2*u2+v2*v2)
      sum3=sum3+h*(u3*u3+v3*v3)
  77  continue
      sum1=sum1+h*sin((nx1-1)*dx)
      sum2=sum2+h*sin((nx2-1)*dx)
      sum3=sum3+h*sin((nx1-1)*dx)
      sumdif=sum1-sumold
      sumold=sum1
      sum0=sqrt(sum0)
      sum=sqrt(sum)
      write(2,666) t,sum,sum1,sum2,sum3
      write(34,667) t,sum0,sum
      write(6,666) t,sum1,sum2,sum3,sumdif
      if(abs(sum1).gt.100.d0) then
      write(6,*) 'sum1 > 100 '
      goto 1234
      endif
      endif

c--- set up velocity profiles to save ------------------------------
      if(mod(iu,nwrite).eq.0) then

      rewind(3)
      rewind(4)
      rewind(7)
      rewind(8)
      rewind(9)
      rewind(10)
      rewind(11)
      rewind(13)
      rewind(14)
      rewind(30)
      rewind(31)
      rewind(32)
      rewind(33)
      rewind(34)
      rewind(35)
      rewind(38)
      do 9 j=2,n+1
      v(j)=(psi(2,j)-psi(nx,j))/2.d0/dx
      u(j)=(psi(nx1,j+1)-psi(nx1,j-1))/2.d0/h
  9   continue
      v(1)=0.d0
      u(1)=aw*sin(dx*(nx1-1))
      u(n+2)=bw*sin(dx*(nx1-1))
      v(n+2)=0.d0
      write(3,333) (y(i),u(i),i=1,n+2)
      write(8,333) (y(i),v(i),i=1,n+2)
      do 10 j=2,n+1
      v(j)=(psi(nx1+1,j)-psi(nx1-1,j))/2.d0/dx
      u(j)=(psi(nx2,j+1)-psi(nx2,j-1))/2.d0/h
10    continue
      u(1)=aw*sin(dx*(nx2-1))
      v(1)=0.d0
      u(n+2)=bw*sin(dx*(nx2-1))
      v(n+2)=0.d0
      write(4,333) (y(i),u(i),i=1,n+2)
      write(9,333) (y(i),v(i),i=1,n+2)
      do 11 j=2,n+1
      v(j)=(psi(nx2+1,j)-psi(nx2-1,j))/2.d0/dx
      u(j)=(psi(nx3,j+1)-psi(nx3,j-1))/2.d0/h
  11  continue
      u(1)=aw*sin(dx*(nx3-1))
      v(1)=0.d0
      u(n+2)=bw*sin(dx*(nx3-1))
      v(n+2)=0.d0
      write(7,333) (y(i),u(i),i=1,n+2)
      write(10,333) (y(i),v(i),i=1,n+2)
      do 12 j=2,n+1
      v(j)=-psi(nx,j)/dx
  12  continue
      v(1)=0.d0
      v(n+2)=0.d0
      write(13,333) (y(i),v(i),i=1,n+2)
      do 79 j=2,n+1
      v(j)=-psi(2,j)/dx
  79  continue
      v(1)=0.d0
      v(n+2)=0.d0
      write(14,333) (y(i),v(i),i=1,n+2)
      do 78 i=1,nx
c     change shear
      shp(i)=(psi(i,0)-2.d0*psi(i,1)+psi(i,2))/h/h
      uhm(i)=.5d0*(psi(i,nm+1)-psi(i,nm-1))/h
      vhm(i)=-psix(i,nm)
      uh0(i)=.5d0*(psi(i,n0+1)-psi(i,n0-1))/h
      vh0(i)=-psix(i,n0)
      uhp(i)=.5d0*(psi(i,np+1)-psi(i,np-1))/h
      vhp(i)=-psix(i,np)
  78  continue
      write(30,333) (xx(i),uhm(i),i=1,nx)
      write(31,333) (xx(i),vhm(i),i=1,nx)
      write(32,333) (xx(i),uhp(i),i=1,nx)
      write(33,333) (xx(i),vhp(i),i=1,nx)
      write(34,333) (xx(i),uh0(i),i=1,nx)
      write(35,333) (xx(i),vh0(i),i=1,nx)
      shpmax=0.
      shpmin=0.
      do 778 i=1,nx
      if(shp(i).gt.shpmax) shpmax=shp(i)
      if(shp(i).lt.shpmin) shpmin=shp(i)
  778 continue

      if((mod(iu,nstore).eq.0).and.(ipap.eq.1).and.(t.gt.papstart)) then
      rewind(40)
      do 20 j=0,n+3

      write(40,1024) (psi(i,j),i=1,nx)
  20  continue
      endif
      write(11,*) t
      write(6,*) 'SHEAR', t, shpmin
      if((shpmax.gt.200).or.(shpmin.lt.-200)) then
      write(6,*) 'Shear > 200'
      goto 1234
       endif
c-----printout of psi
      if((t.gt.tout1).and.(tout1.gt.0)) then
      open(45,file='tout1.m',status='unknown')
      write(45,*),'% time =',t,'n=',n,'nx=',nx
      do 1111 j=0,n+2
      write(45,1024) (psi(i,j),i=1,nx)
1111  continue
      do 1112 j=2,n+3
      write(45,1024) (-psi(i,n+3-j),i=1,nx)
1112  continue
      close(unit=45)
      tout1=-1.0
      endif
      if((t.gt.tout2).and.(tout2.gt.0)) then
      open(45,file='tout2.m',status='unknown')
      write(45,*),'% time =',t,'n=',n,'nx=',nx
      do 1113 j=0,n+2
      write(45,1024) (psi(i,j),i=1,nx)
1113  continue
      do 1114 j=2,n+3
      write(45,1024) (-psi(i,n+3-j),i=1,nx)
1114  continue
      close(unit=45)
      tout2=-1.0
      endif
      if((t.gt.tout3).and.(tout3.gt.0)) then
      open(45,file='tout3.m',status='unknown')
      write(45,*),'% time =',t,'n=',n,'nx=',nx
      do 1115 j=0,n+2
      write(45,1024) (psi(i,j),i=1,nx)
1115  continue
      do 1116 j=2,n+3
      write(45,1024) (-psi(i,n+3-j),i=1,nx)
1116  continue
      close(unit=45)
      tout3=-1.0
      endif
      if((t.gt.tout4).and.(tout4.gt.0)) then
      open(45,file='tout4.m',status='unknown')
      write(45,*),'% time =',t,'n=',n,'nx=',nx
      do 1117 j=0,n+2
      write(45,1024) (psi(i,j),i=1,nx)
1117  continue
      do 1118 j=2,n+3
      write(45,1024) (-psi(i,n+3-j),i=1,nx)
1118  continue
      close(unit=45)
      tout4=-1.0
      endif
      if((t.gt.tout5).and.(tout5.gt.0)) then
      open(45,file='tout5.m',status='unknown')
      write(45,*),'% time =',t,'n=',n,'nx=',nx
      do 1119 j=0,n+2
      write(45,1024) (psi(i,j),i=1,nx)
1119  continue
      do 1120 j=2,n+3
      write(45,1024) (-psi(i,n+3-j),i=1,nx)
1120  continue
      close(unit=45)
      tout5=-1.0
      endif
      endif
c-----------------------
      if(mod(iu,nspec).eq.0) then
      do 459 i=1,nx
      zvhp(i)=vhp(i)
      zuhp(i)=uhp(i)
  459 continue
      call cfftf(nx,zvhp,wsave)
      call cfftf(nx,zuhp,wsave)
      endif
      if(t.gt.tmax) goto 999

4     continue
 999  continue
 1234 continue
      write(6,*) 'FINAL t===', t,'Reynolds==',rm
      write(11,*) t
      do 220 j=0,n+2
      write(112,1024) (psi(i,j),i=1,nx)
 220  continue
      do 221 j=2,n+3
      write(112,1024) (-psi(i,n+3-j),i=1,nx)
221   continue

 222  format(2x,e13.6,4x,e13.6)
 64   format(3x,64f13.4)
 128  format(2x,128f13.4)
 256  format(2x,256f13.6)
 512  format(2x,512f13.6)
1024  format(2x,1024f17.10)

 666  format(2x,e13.6,3x,e13.6,3x,e13.6,3x,e13.6,3x,e13.6)
 333  format(2x,e13.6,3x,e13.6)
 334  format(2x,e13.6,3x,e13.6,3x,e13.6)
 667  format(1x,e13.6,4x,e13.6,4x,e13.6)
      stop
      end

      SUBROUTINE CFFTI (N,WSAVE)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 WSAVE
C     ******************************************************************
C
C     SUBROUTINE CFFTI(N,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE CFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C     BOTH CFFTF AND CFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH
C     A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
C     STORED IN WSAVE.
C
C     INPUT PARAMETER
C
C     N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED
C
C     OUTPUT PARAMETER
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4*N+15
C             THE SAME WORK ARRAY CAN BE USED FOR BOTH CFFTF AND CFFTB
C             AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS
C             ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF
C             WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF CFFTF OR CFFTB.
C
      DIMENSION       WSAVE(1)
C
C THE FOLLOWING CALL IS FOR GATHERING LIBRARY STATISTICS AT NCAR
C
C     CALL Q8QST4(4HXLIB,7HCFFTI  ,7HFFTPACK,10HVERSION  1)
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL CFFTI1 (N, WSAVE(IW1), WSAVE(IW2))
      RETURN
      END
      SUBROUTINE CFFTI1 (N,WA,IFAC)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION       IFAC(*), NTRYH(4), WA(*)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4 .GT. 0) THEN
      GOTO 103
      ELSE
      GOTO 102
      END IF
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 8.0d0*ATAN(1.0d0)
      ARG1 = TPI/DFLOAT(N)
      DC = DCOS(ARG1)
      DS = DSIN(ARG1)
      WA(1) = DC
      WA(2) = DS
      NT = N+N
      DO 108 I=4,NT,2
         WA(I-1) = DC*WA(I-3)-DS*WA(I-2)
         WA(I) = DS*WA(I-3)+DC*WA(I-2)
  108 CONTINUE
*	write(*,700)
700	format('PASE')
      RETURN
      END

      SUBROUTINE CFFTB (N,C,WSAVE)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 C, WSAVE

C     ******************************************************************
C
C     SUBROUTINE CFFTB(N,C,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE CFFTB COMPUTES THE BACKWARD COMPLEX DISCRETE FOURIER
C     TRANSFORM (THE FOURIER SYNTHESIS). EQUIVALENTLY , CFFTB COMPUTES
C     A COMPLEX PERIODIC SEQUENCE FROM ITS FOURIER COEFFICIENTS.
C     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C.
C
C     A CALL OF CFFTF FOLLOWED BY A CALL OF CFFTB WILL MULTIPLY THE
C     SEQUENCE BY N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE CFFTB MUST BE
C     INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE).
C
C     INPUT PARAMETERS
C
C
C     N      THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS
C            MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES.
C
C     C      A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C
C     WSAVE   A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15
C             IN THE PROGRAM THAT CALLS CFFTB. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE) AND A
C             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE
C             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C             THE SAME WSAVE ARRAY CAN BE USED BY CFFTF AND CFFTB.
C
C     OUTPUT PARAMETERS
C
C     C      FOR J=1,...,N
C
C                C(J)=THE SUM FROM K=1,...,N OF
C
C                      C(K)*EXP(I*J*K*2*PI/N)
C
C                            WHERE I=SQRT(-1)
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
C             DESTROYED BETWEEN CALLS OF SUBROUTINE CFFTF OR CFFTB
      DIMENSION       C(1)       ,WSAVE(1)
C
C THE FOLLOWING CALL IS FOR GATHERING LIBRARY STATISTICS AT NCAR
C
C     CALL Q8QST4(4HXLIB,7HCFFTB  ,7HFFTPACK,10HVERSION  1)
      IF (N .EQ. 1) then
*			write(*,701)
701			format('PASE1')
			 RETURN
	end if
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
*	write(*,700)
700	format('PASE')

      RETURN
      END

      SUBROUTINE CFFTB1 (N,C,CH,WA,IFAC)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 C
      DIMENSION       CH(1)      ,C(1)       ,WA(1)      ,IFAC(*)
      NF = IFAC(2)
      L1 = 1
      DO 105 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDOT = IDO+IDO
         IDL1 = IDOT*L1
         IF (IP .NE. 4) GO TO 101
         IX2 = L1+L1
         IX3 = IX2+L1
         CALL PASSB4 (IDOT,L1,IDL1,IX2,IX3,C,C,C,CH,CH,WA,WA,WA)
         GO TO 104
  101    IF (IP .NE. 2) GO TO 102
         CALL PASSB2 (IDOT,L1,IDL1,C,C,C,CH,CH,WA)
         GO TO 104
  102    IF (IP .NE. 3) GO TO 103
         IX2 = L1+L1
         CALL PASSB3 (IDOT,L1,IDL1,IX2,C,C,C,CH,CH,WA,WA)
         GO TO 104
  103    CALL PASSB (IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA)
  104    L1 = L2
  105 CONTINUE
      RETURN
      END
      SUBROUTINE PASSB2 (IDO,L1,IDL1,CC,C1,C2,CH,CH2,WA1)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION       CC(IDO,2,L1)           ,C1(IDO,L1,2)           ,
     1                C2(IDL1,2) ,CH(IDO,L1,2)           ,CH2(IDL1,2),
     2                WA1(L1,*)
      IDOT = IDO/2
      IF (IDO .LT. L1) GO TO 103
      DO 102 K=1,L1
         DO 101 I=1,IDO
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            CH(I,K,2) = CC(I,1,K)-CC(I,2,K)
  101    CONTINUE
  102 CONTINUE
      GO TO 106
  103 DO 105 I=1,IDO
         DO 104 K=1,L1
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            CH(I,K,2) = CC(I,1,K)-CC(I,2,K)
  104    CONTINUE
  105 CONTINUE
  106 DO 107 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  107 CONTINUE
      DO 108 K=1,L1
         C1(1,K,2) = CH(1,K,2)
         C1(2,K,2) = CH(2,K,2)
  108 CONTINUE
      IF (IDO .EQ. 2) RETURN
      IF (IDOT .LT. L1) GO TO 111
      DO 110 K=1,L1
         DO 109 I=4,IDO,2
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)+WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)-
     1                    WA1(L1,I-2)*CH(I,K,2)
  109    CONTINUE
  110 CONTINUE
      RETURN
  111 DO 113 I=4,IDO,2
         DO 112 K=1,L1
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)+WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)-
     1                    WA1(L1,I-2)*CH(I,K,2)
  112    CONTINUE
  113 CONTINUE
      RETURN
      END
      SUBROUTINE PASSB3 (IDO,L1,IDL1,IX2,CC,C1,C2,CH,CH2,WA1,WA2)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION       CC(IDO,3,L1)           ,C1(IDO,L1,3)           ,
     1                C2(IDL1,3) ,CH(IDO,L1,3)           ,CH2(IDL1,3),
     2                WA1(L1,*)  ,WA2(IX2,*)
      DATA TAUR,TAUI /-.5d0,.866025403784439d0/
      IDOT = IDO/2
      IF (IDO .LT. L1) GO TO 103
      DO 102 K=1,L1
         DO 101 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
            CH(I,K,2) = CC(I,2,K)+CC(I,3,K)
            CH(I,K,3) = CC(I,2,K)-CC(I,3,K)
  101    CONTINUE
  102 CONTINUE
      GO TO 106
  103 DO 105 I=1,IDO
         DO 104 K=1,L1
            CH(I,K,1) = CC(I,1,K)
            CH(I,K,2) = CC(I,2,K)+CC(I,3,K)
            CH(I,K,3) = CC(I,2,K)-CC(I,3,K)
  104    CONTINUE
  105 CONTINUE
C
  106 DO 107 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)+CH2(IK,2)
         C2(IK,2) = CH2(IK,1)+TAUR*CH2(IK,2)
         C2(IK,3) = TAUI*CH2(IK,3)
  107 CONTINUE
      DO 108 IK=2,IDL1,2
         CH2(IK-1,2) = C2(IK-1,2)-C2(IK,3)
         CH2(IK-1,3) = C2(IK-1,2)+C2(IK,3)
  108 CONTINUE
      DO 109 IK=2,IDL1,2
         CH2(IK,2) = C2(IK,2)+C2(IK-1,3)
         CH2(IK,3) = C2(IK,2)-C2(IK-1,3)
  109 CONTINUE
      DO 111 J=2,3
         DO 110 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  110    CONTINUE
  111 CONTINUE
      IF (IDO .EQ. 2) RETURN
      IF (IDOT-1 .LT. L1) GO TO 114
      DO 113 K=1,L1
         DO 112 I=4,IDO,2
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)+WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)-
     1                    WA1(L1,I-2)*CH(I,K,2)
            C1(I,K,3) = WA2(IX2-1,I-2)*CH(I,K,3)+
     1                  WA2(IX2,I-2)*CH(I-1,K,3)
            C1(I-1,K,3) = WA2(IX2-1,I-2)*CH(I-1,K,3)-
     1                    WA2(IX2,I-2)*CH(I,K,3)
  112    CONTINUE
  113 CONTINUE
      RETURN
  114 DO 116 I=4,IDO,2
         DO 115 K=1,L1
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)+WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)-
     1                    WA1(L1,I-2)*CH(I,K,2)
            C1(I,K,3) = WA2(IX2-1,I-2)*CH(I,K,3)+
     1                  WA2(IX2,I-2)*CH(I-1,K,3)
            C1(I-1,K,3) = WA2(IX2-1,I-2)*CH(I-1,K,3)-
     1                    WA2(IX2,I-2)*CH(I,K,3)
  115    CONTINUE
  116 CONTINUE
      RETURN
      END
      SUBROUTINE PASSB4 (IDO,L1,IDL1,IX2,IX3,CC,C1,C2,CH,CH2,WA1,WA2,
     1                   WA3)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION       CC(IDO,4,L1)           ,C1(IDO,L1,4)           ,
     1                C2(IDL1,4) ,CH(IDO,L1,4)           ,CH2(IDL1,4),
     2                WA1(L1,*)  ,WA2(IX2,*) ,WA3(IX3,*)
      IDOT = IDO/2
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 K=1,L1
         DO 101 I=2,IDO,2
            CH(I-1,K,4) = CC(I,4,K)-CC(I,2,K)
  101    CONTINUE
         DO 102 I=2,IDO,2
            CH(I,K,4) = CC(I-1,2,K)-CC(I-1,4,K)
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
         DO 104 I=1,IDO
            CH(I,K,2) = CC(I,1,K)+CC(I,3,K)
            CH(I,K,3) = CC(I,2,K)+CC(I,4,K)
            CH(I,K,1) = CC(I,1,K)-CC(I,3,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 111
  106 DO 108 I=2,IDO,2
         DO 107 K=1,L1
            CH(I-1,K,4) = CC(I,4,K)-CC(I,2,K)
            CH(I,K,4) = CC(I-1,2,K)-CC(I-1,4,K)
  107    CONTINUE
  108 CONTINUE
      DO 110 I=1,IDO
         DO 109 K=1,L1
            CH(I,K,2) = CC(I,1,K)+CC(I,3,K)
            CH(I,K,3) = CC(I,2,K)+CC(I,4,K)
            CH(I,K,1) = CC(I,1,K)-CC(I,3,K)
  109    CONTINUE
  110 CONTINUE
  111 DO 112 IK=1,IDL1
         C2(IK,1) = CH2(IK,2)+CH2(IK,3)
  112 CONTINUE
      DO 113 IK=1,IDL1
         CH2(IK,3) = CH2(IK,2)-CH2(IK,3)
  113 CONTINUE
      DO 114 IK=1,IDL1
         CH2(IK,2) = CH2(IK,1)+CH2(IK,4)
  114 CONTINUE
      DO 115 IK=1,IDL1
         CH2(IK,4) = CH2(IK,1)-CH2(IK,4)
  115 CONTINUE
      DO 117 J=2,4
         DO 116 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  116    CONTINUE
  117 CONTINUE
      IF (IDO .EQ. 2) RETURN
      IF (IDOT .LT. L1) GO TO 120
      DO 119 K=1,L1
         DO 118 I=4,IDO,2
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)+WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)-
     1                    WA1(L1,I-2)*CH(I,K,2)
            C1(I,K,3) = WA2(IX2-1,I-2)*CH(I,K,3)+
     1                  WA2(IX2,I-2)*CH(I-1,K,3)
            C1(I-1,K,3) = WA2(IX2-1,I-2)*CH(I-1,K,3)-
     1                    WA2(IX2,I-2)*CH(I,K,3)
            C1(I,K,4) = WA3(IX3-1,I-2)*CH(I,K,4)+
     1                  WA3(IX3,I-2)*CH(I-1,K,4)
            C1(I-1,K,4) = WA3(IX3-1,I-2)*CH(I-1,K,4)-
     1                    WA3(IX3,I-2)*CH(I,K,4)
  118    CONTINUE
  119 CONTINUE
      RETURN
  120 DO 122 I=4,IDO,2
         DO 121 K=1,L1
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)+WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)-
     1                    WA1(L1,I-2)*CH(I,K,2)
            C1(I,K,3) = WA2(IX2-1,I-2)*CH(I,K,3)+
     1                  WA2(IX2,I-2)*CH(I-1,K,3)
            C1(I-1,K,3) = WA2(IX2-1,I-2)*CH(I-1,K,3)-
     1                    WA2(IX2,I-2)*CH(I,K,3)
            C1(I,K,4) = WA3(IX3-1,I-2)*CH(I,K,4)+
     1                  WA3(IX3,I-2)*CH(I-1,K,4)
            C1(I-1,K,4) = WA3(IX3-1,I-2)*CH(I-1,K,4)-
     1                    WA3(IX3,I-2)*CH(I,K,4)
  121    CONTINUE
  122 CONTINUE
      RETURN
      END
      SUBROUTINE PASSB (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,WA(1)      ,C2(IDL1,IP),
     2                CH2(IDL1,IP)
      IDOT = IDO/2
      NT = IP*IDL1
      IPP2 = IP+2
      IPPH = (IP+1)/2
      L1T = L1+L1
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 J=2,IPPH
         JC = IPP2-J
         DO 102 K=1,L1
            DO 101 I=1,IDO
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  101       CONTINUE
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
         DO 104 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 112
  106 DO 109 J=2,IPPH
         JC = IPP2-J
         DO 108 I=1,IDO
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      DO 111 I=1,IDO
         DO 110 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  110    CONTINUE
  111 CONTINUE
  112 DO 113 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  113 CONTINUE
      IDJ = 0
      DO 115 J=2,IPPH
         JC = IPP2-J
         IDJ = IDJ+IDL1
         DO 114 IK=1,IDL1
            C2(IK,J) = CH2(IK,1)+WA(IDJ-1)*CH2(IK,2)
            C2(IK,JC) = WA(IDJ)*CH2(IK,IP)
  114    CONTINUE
  115 CONTINUE
      DO 117 J=2,IPPH
         DO 116 IK=1,IDL1
            C2(IK,1) = C2(IK,1)+CH2(IK,J)
  116    CONTINUE
  117 CONTINUE
C
      IDL = 0
      DO 120 L=2,IPPH
         LC = IPP2-L
         IDL = IDL+IDL1
         IDLJ = IDL
         DO 119 J=3,IPPH
            JC = IPP2-J
            IDLJ = IDLJ+IDL
            IF (IDLJ .GT. NT) IDLJ = IDLJ-NT
            WAR = WA(IDLJ-1)
            WAI = WA(IDLJ)
            DO 118 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC)
  118       CONTINUE
  119    CONTINUE
  120 CONTINUE
C
      DO 122 J=2,IPPH
         JC = IPP2-J
         DO 121 IK=2,IDL1,2
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
  121    CONTINUE
  122 CONTINUE
      DO 124 J=2,IPPH
         JC = IPP2-J
         DO 123 IK=2,IDL1,2
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  123    CONTINUE
  124 CONTINUE
C
      DO 126 J=2,IP
         DO 125 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  125    CONTINUE
  126 CONTINUE
      IF (IDO .EQ. 2) RETURN
      IDJ = 0
      IF (IDOT .GT. L1) GO TO 130
      DO 129 J=2,IP
         IDJ = IDJ+L1T
         IDIJ = 0
         DO 128 I=4,IDO,2
            IDIJ = IDIJ+IDJ
            DO 127 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  127       CONTINUE
  128    CONTINUE
  129 CONTINUE
      RETURN
  130 DO 134 J=2,IP
         IDJ = IDJ+L1T
         DO 133 K=1,L1
            IDIJ = 0
            DO 131 I=4,IDO,2
               IDIJ = IDIJ+IDJ
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
  131       CONTINUE
            IDIJ = 0
            DO 132 I=4,IDO,2
               IDIJ = IDIJ+IDJ
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  132       CONTINUE
  133    CONTINUE
  134 CONTINUE
      RETURN
      END
      SUBROUTINE CFFTF (N,C,WSAVE)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 C, WSAVE
C     ******************************************************************
C
C     SUBROUTINE CFFTF(N,C,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE CFFTF COMPUTES THE FORWARD COMPLEX DISCRETE FOURIER
C     TRANSFORM (THE FOURIER ANALYSIS). EQUIVALENTLY , CFFTF COMPUTES
C     THE FOURIER COEFFICIENTS OF A COMPLEX PERIODIC SEQUENCE.
C     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C.
C
C     THE TRANSFORM IS NOT NORMALIZED. TO OBTAIN A NORMALIZED TRANSFORM
C     THE OUTPUT MUST BE DIVIDED BY N. OTHERWISE A CALL OF CFFTF
C     FOLLOWED BY A CALL OF CFFTB WILL MULTIPLY THE SEQUENCE BY N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE CFFTF MUST BE
C     INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE).
C
C     INPUT PARAMETERS
C
C
C     N      THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS
C            MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. N
C
C     C      A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C
C     WSAVE   A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15
C             IN THE PROGRAM THAT CALLS CFFTF. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE) AND A
C             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE
C             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C             THE SAME WSAVE ARRAY CAN BE USED BY CFFTF AND CFFTB.
C
C     OUTPUT PARAMETERS
C
C     C      FOR J=1,...,N
C
C                C(J)=THE SUM FROM K=1,...,N OF
C
C                      C(K)*EXP(-I*J*K*2*PI/N)
C
C                            WHERE I=SQRT(-1)
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
C             DESTROYED BETWEEN CALLS OF SUBROUTINE CFFTF OR CFFTB
C
      DIMENSION       C(1)       ,WSAVE(1)
C
C THE FOLLOWING CALL IS FOR GATHERING LIBRARY STATISTICS AT NCAR
C
C     CALL Q8QST4(4HXLIB,7HCFFTF  ,7HFFTPACK,10HVERSION  1)
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END
      SUBROUTINE CFFTF1 (N,C,CH,WA,IFAC)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX*16 C
      DIMENSION       CH(1)      ,C(1)       ,WA(1)      ,IFAC(*)
      NF = IFAC(2)
      L1 = 1
      DO 105 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDOT = IDO+IDO
         IDL1 = IDOT*L1
         IF (IP .NE. 4) GO TO 101
         IX2 = L1+L1
         IX3 = IX2+L1
         CALL PASSF4 (IDOT,L1,IDL1,IX2,IX3,C,C,C,CH,CH,WA,WA,WA)
         GO TO 104
  101    IF (IP .NE. 2) GO TO 102
         CALL PASSF2 (IDOT,L1,IDL1,C,C,C,CH,CH,WA)
         GO TO 104
  102    IF (IP .NE. 3) GO TO 103
         IX2 = L1+L1
         CALL PASSF3 (IDOT,L1,IDL1,IX2,C,C,C,CH,CH,WA,WA)
         GO TO 104
  103    CALL PASSF (IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA)
  104    L1 = L2
  105 CONTINUE
      RETURN
      END
      SUBROUTINE PASSF2 (IDO,L1,IDL1,CC,C1,C2,CH,CH2,WA1)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION       CC(IDO,2,L1)           ,C1(IDO,L1,2)           ,
     1                C2(IDL1,2) ,CH(IDO,L1,2)           ,CH2(IDL1,2),
     2                WA1(L1,*)
      IDOT = IDO/2
      IF (IDO .LT. L1) GO TO 103
      DO 102 K=1,L1
         DO 101 I=1,IDO
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            CH(I,K,2) = CC(I,1,K)-CC(I,2,K)
  101    CONTINUE
  102 CONTINUE
      GO TO 106
  103 DO 105 I=1,IDO
         DO 104 K=1,L1
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            CH(I,K,2) = CC(I,1,K)-CC(I,2,K)
  104    CONTINUE
  105 CONTINUE
  106 DO 107 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  107 CONTINUE
      DO 108 K=1,L1
         C1(1,K,2) = CH(1,K,2)
         C1(2,K,2) = CH(2,K,2)
  108 CONTINUE
      IF (IDO .EQ. 2) RETURN
      IF (IDOT .LT. L1) GO TO 111
      DO 110 K=1,L1
         DO 109 I=4,IDO,2
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)-WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)+
     1                    WA1(L1,I-2)*CH(I,K,2)
  109    CONTINUE
  110 CONTINUE
      RETURN
  111 DO 113 I=4,IDO,2
         DO 112 K=1,L1
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)-WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)+
     1                    WA1(L1,I-2)*CH(I,K,2)
  112    CONTINUE
  113 CONTINUE
      RETURN
      END
      SUBROUTINE PASSF3 (IDO,L1,IDL1,IX2,CC,C1,C2,CH,CH2,WA1,WA2)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION       CC(IDO,3,L1)           ,C1(IDO,L1,3)           ,
     1                C2(IDL1,3) ,CH(IDO,L1,3)           ,CH2(IDL1,3),
     2                WA1(L1,*)  ,WA2(IX2,*)
      DATA TAUR,TAUI /-.5d0,-.866025403784439d0/
      IDOT = IDO/2
      IF (IDO .LT. L1) GO TO 103
      DO 102 K=1,L1
         DO 101 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
            CH(I,K,2) = CC(I,2,K)+CC(I,3,K)
            CH(I,K,3) = CC(I,2,K)-CC(I,3,K)
  101    CONTINUE
  102 CONTINUE
      GO TO 106
  103 DO 105 I=1,IDO
         DO 104 K=1,L1
            CH(I,K,1) = CC(I,1,K)
            CH(I,K,2) = CC(I,2,K)+CC(I,3,K)
            CH(I,K,3) = CC(I,2,K)-CC(I,3,K)
  104    CONTINUE
  105 CONTINUE
C
  106 DO 107 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)+CH2(IK,2)
         C2(IK,2) = CH2(IK,1)+TAUR*CH2(IK,2)
         C2(IK,3) = TAUI*CH2(IK,3)
  107 CONTINUE
      DO 108 IK=2,IDL1,2
         CH2(IK-1,2) = C2(IK-1,2)-C2(IK,3)
         CH2(IK-1,3) = C2(IK-1,2)+C2(IK,3)
  108 CONTINUE
      DO 109 IK=2,IDL1,2
         CH2(IK,2) = C2(IK,2)+C2(IK-1,3)
         CH2(IK,3) = C2(IK,2)-C2(IK-1,3)
  109 CONTINUE
      DO 111 J=2,3
         DO 110 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  110    CONTINUE
  111 CONTINUE
      IF (IDO .EQ. 2) RETURN
      IF (IDOT-1 .LT. L1) GO TO 114
      DO 113 K=1,L1
         DO 112 I=4,IDO,2
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)-WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)+
     1                    WA1(L1,I-2)*CH(I,K,2)
            C1(I,K,3) = WA2(IX2-1,I-2)*CH(I,K,3)-
     1                  WA2(IX2,I-2)*CH(I-1,K,3)
            C1(I-1,K,3) = WA2(IX2-1,I-2)*CH(I-1,K,3)+
     1                    WA2(IX2,I-2)*CH(I,K,3)
  112    CONTINUE
  113 CONTINUE
      RETURN
  114 DO 116 I=4,IDO,2
         DO 115 K=1,L1
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)-WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)+
     1                    WA1(L1,I-2)*CH(I,K,2)
            C1(I,K,3) = WA2(IX2-1,I-2)*CH(I,K,3)-
     1                  WA2(IX2,I-2)*CH(I-1,K,3)
            C1(I-1,K,3) = WA2(IX2-1,I-2)*CH(I-1,K,3)+
     1                    WA2(IX2,I-2)*CH(I,K,3)
  115    CONTINUE
  116 CONTINUE
      RETURN
      END
      SUBROUTINE PASSF4 (IDO,L1,IDL1,IX2,IX3,CC,C1,C2,CH,CH2,WA1,WA2,
     1                   WA3)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION       CC(IDO,4,L1)           ,C1(IDO,L1,4)           ,
     1                C2(IDL1,4) ,CH(IDO,L1,4)           ,CH2(IDL1,4),
     2                WA1(L1,*)  ,WA2(IX2,*) ,WA3(IX3,*)
      IDOT = IDO/2
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 K=1,L1
         DO 101 I=2,IDO,2
            CH(I-1,K,4) = CC(I,2,K)-CC(I,4,K)
  101    CONTINUE
         DO 102 I=2,IDO,2
            CH(I,K,4) = CC(I-1,4,K)-CC(I-1,2,K)
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
         DO 104 I=1,IDO
            CH(I,K,2) = CC(I,1,K)+CC(I,3,K)
            CH(I,K,3) = CC(I,2,K)+CC(I,4,K)
            CH(I,K,1) = CC(I,1,K)-CC(I,3,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 111
  106 DO 108 I=2,IDO,2
         DO 107 K=1,L1
            CH(I,K,4) = CC(I-1,4,K)-CC(I-1,2,K)
            CH(I-1,K,4) = CC(I,2,K)-CC(I,4,K)
  107    CONTINUE
  108 CONTINUE
      DO 110 I=1,IDO
         DO 109 K=1,L1
            CH(I,K,2) = CC(I,1,K)+CC(I,3,K)
            CH(I,K,3) = CC(I,2,K)+CC(I,4,K)
            CH(I,K,1) = CC(I,1,K)-CC(I,3,K)
  109    CONTINUE
  110 CONTINUE
  111 DO 112 IK=1,IDL1
         C2(IK,1) = CH2(IK,2)+CH2(IK,3)
  112 CONTINUE
      DO 113 IK=1,IDL1
         CH2(IK,3) = CH2(IK,2)-CH2(IK,3)
  113 CONTINUE
      DO 114 IK=1,IDL1
         CH2(IK,2) = CH2(IK,1)+CH2(IK,4)
  114 CONTINUE
      DO 115 IK=1,IDL1
         CH2(IK,4) = CH2(IK,1)-CH2(IK,4)
  115 CONTINUE
      DO 117 J=2,4
         DO 116 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  116    CONTINUE
  117 CONTINUE
      IF (IDO .EQ. 2) RETURN
      IF (IDOT .LT. L1) GO TO 120
      DO 119 K=1,L1
         DO 118 I=4,IDO,2
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)-WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)+
     1                    WA1(L1,I-2)*CH(I,K,2)
            C1(I,K,3) = WA2(IX2-1,I-2)*CH(I,K,3)-
     1                  WA2(IX2,I-2)*CH(I-1,K,3)
            C1(I-1,K,3) = WA2(IX2-1,I-2)*CH(I-1,K,3)+
     1                    WA2(IX2,I-2)*CH(I,K,3)
            C1(I,K,4) = WA3(IX3-1,I-2)*CH(I,K,4)-
     1                  WA3(IX3,I-2)*CH(I-1,K,4)
            C1(I-1,K,4) = WA3(IX3-1,I-2)*CH(I-1,K,4)+
     1                    WA3(IX3,I-2)*CH(I,K,4)
  118    CONTINUE
  119 CONTINUE
      RETURN
  120 DO 122 I=4,IDO,2
         DO 121 K=1,L1
            C1(I,K,2) = WA1(L1-1,I-2)*CH(I,K,2)-WA1(L1,I-2)*CH(I-1,K,2)
            C1(I-1,K,2) = WA1(L1-1,I-2)*CH(I-1,K,2)+
     1                    WA1(L1,I-2)*CH(I,K,2)
            C1(I,K,3) = WA2(IX2-1,I-2)*CH(I,K,3)-
     1                  WA2(IX2,I-2)*CH(I-1,K,3)
            C1(I-1,K,3) = WA2(IX2-1,I-2)*CH(I-1,K,3)+
     1                    WA2(IX2,I-2)*CH(I,K,3)
            C1(I,K,4) = WA3(IX3-1,I-2)*CH(I,K,4)-
     1                  WA3(IX3,I-2)*CH(I-1,K,4)
            C1(I-1,K,4) = WA3(IX3-1,I-2)*CH(I-1,K,4)+
     1                    WA3(IX3,I-2)*CH(I,K,4)
  121    CONTINUE
  122 CONTINUE
      RETURN
      END
      SUBROUTINE PASSF (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,WA(1)      ,C2(IDL1,IP),
     2                CH2(IDL1,IP)
      IDOT = IDO/2
      NT = IP*IDL1
      IPP2 = IP+2
      IPPH = (IP+1)/2
      L1T = L1+L1
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 J=2,IPPH
         JC = IPP2-J
         DO 102 K=1,L1
            DO 101 I=1,IDO
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  101       CONTINUE
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
         DO 104 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 112
  106 DO 109 J=2,IPPH
         JC = IPP2-J
         DO 108 I=1,IDO
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      DO 111 I=1,IDO
         DO 110 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  110    CONTINUE
  111 CONTINUE
  112 DO 113 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  113 CONTINUE
      IDJ = 0
      DO 115 J=2,IPPH
         JC = IPP2-J
         IDJ = IDJ+IDL1
         DO 114 IK=1,IDL1
            C2(IK,J) = CH2(IK,1)+WA(IDJ-1)*CH2(IK,2)
            C2(IK,JC) = -WA(IDJ)*CH2(IK,IP)
  114    CONTINUE
  115 CONTINUE
      DO 117 J=2,IPPH
         DO 116 IK=1,IDL1
            C2(IK,1) = C2(IK,1)+CH2(IK,J)
  116    CONTINUE
  117 CONTINUE
C
      IDL = 0
      DO 120 L=2,IPPH
         LC = IPP2-L
         IDL = IDL+IDL1
         IDLJ = IDL
         DO 119 J=3,IPPH
            JC = IPP2-J
            IDLJ = IDLJ+IDL
            IF (IDLJ .GT. NT) IDLJ = IDLJ-NT
            WAR = WA(IDLJ-1)
            WAI = WA(IDLJ)
            DO 118 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)
  118       CONTINUE
  119    CONTINUE
  120 CONTINUE
C
      DO 122 J=2,IPPH
         JC = IPP2-J
         DO 121 IK=2,IDL1,2
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
  121    CONTINUE
  122 CONTINUE
      DO 124 J=2,IPPH
         JC = IPP2-J
         DO 123 IK=2,IDL1,2
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  123    CONTINUE
  124 CONTINUE
C
      DO 126 J=2,IP
         DO 125 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  125    CONTINUE
  126 CONTINUE
      IF (IDO .EQ. 2) RETURN
      IDJ = 0
      IF (IDOT .GT. L1) GO TO 130
      DO 129 J=2,IP
         IDJ = IDJ+L1T
         IDIJ = 0
         DO 128 I=4,IDO,2
            IDIJ = IDIJ+IDJ
            DO 127 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  127       CONTINUE
  128    CONTINUE
  129 CONTINUE
      RETURN
  130 DO 134 J=2,IP
         IDJ = IDJ+L1T
         DO 133 K=1,L1
            IDIJ = 0
            DO 131 I=4,IDO,2
               IDIJ = IDIJ+IDJ
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
  131       CONTINUE
            IDIJ = 0
            DO 132 I=4,IDO,2
               IDIJ = IDIJ+IDJ
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  132       CONTINUE
  133    CONTINUE
  134 CONTINUE
      RETURN
      END


      subroutine vgcap_inv( iflg,sl, slr, smr, alpha, beta,
     &       slcut, sucut, hlcut, hucut, ac3, ac4, bc3, bc4, hp, dslh)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C**********************************************************************
CD1
CD1 PURPOSE
CD1
CD1 To compute the saturation from capillary pressure and derivatives for the
CD1 van Genuchten model. The inverse of subroutine vg_cap.f .
CD1
C**********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2 4-04-07      george Zyvoloski initial implementation
CD2
CD2 $Log:   /pvcs.config/fehm90/src/vgcap_inv.f_a  $
C**********************************************************************
CD3
CD3 INTERFACES
CD3
CD3 Formal Calling Parameters
CD3
CD3 Identifier   Type    Use     Description
CD3
CD3 sl           real*8   I/O    Liquid saturation on input,
CD3                                  normalized liquid saturation on
CD3                                  output
CD3 slr          real*8   I      Residual liquid saturation
CD3 smr          real*8   I      Maximum liquid saturation
CD3 alpha        real*8   I      Van Ganuchten parameter
CD3 beta         real*8   I      Van Ganuchten parameter
CD3 ac1          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 ac2          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 ac3          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 ac4          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 smcut        real*8   I      Lower cutoff saturation below which a
CD3                                  spline fit is used for capillary
CD3                                  pressure versus saturation
CD3 sucut        real*8   I      Upper cutoff saturation above which a
CD3                                  linear fit is used for capillary
CD3                                  pressure versus saturation
CD3 bc3          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 bc4          real*8   I      Parameter in spline fit for capillary
CD3                                  pressure at low saturations
CD3 hp           real*8   O      Capillary pressure
CD3 dhp          real*8   O      Derivative of capillary pressure with
CD3                                  respect to saturation
CD3
CD3 Interface Tables
CD3
CD3 None
CD3
CD3 Files
CD3
CD3 NONE
CD3
C**********************************************************************
CD4
CD4 GLOBAL OBJECTS
CD4
CD4 Global Constants
CD4
CD4 NONE
CD4
CD4 Global Types
CD4
CD4 NONE
CD4
CD4 Global Variables
CD4
CD4 NONE
CD4
CD4 Global Subprograms
CD4
CD4 NONE
CD4
C**********************************************************************
CD5
CD5 LOCAL IDENTIFIERS
CD5
CD5 Local Constants
CD5
CD5 NONE
CD5
CD5 Local Types
CD5
CD5 NONE
CD5
CD5 Local variables
CD5
CD5 Identifier   Type        Description
CD5
CD5 alamda       real*8      Exponent in correlation
CD5 ds           real*8      Reciprocal of demoninator in normalized
CD5                              saturation expression
CD5 denom        real*8      Denominator in normalized saturation
CD5                              expression
CD5 star         real*8      Normalized saturation
CD5 alpi         real*8      Exponent in correlation
CD5 hp           real*8      Capillary pressure before unit conversion
CD5 dhp          real*8      Derivative of hp with respect to saturation
CD5 termstar1    real*8      Term used in capillary pressure calculation
CD5 termstar2    real*8      Term used in capillary pressure calculation
CD5 termb1       real*8      Term used in capillary pressure calculation
CD5 termb2       real*8      Term used in capillary pressure calculation
CD5
CD5 Local Subprograms
CD5
CD5 None
CD5
C**********************************************************************
CD6
CD6 ASSUMPTIONS AND LIMITATIONS
CD6
CD6 N/A
CD6
C**********************************************************************
CD7
CD7 SPECIAL COMMENTS
CD7
CD7  Requirements from SDN: 10086-RD-2.20-00
CD7    SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD7    FEHM Application Version 2.20
CD7
C**********************************************************************
CD8
CD8 REQUIREMENTS TRACEABILITY
CD8
CD8 2.4.4 Relative-permeability and capillary-pressure functions
CD8
C**********************************************************************
CDA
CDA REFERENCES
CDA
CDA See GZSOLVE SRS, MMS, and SDD for documentation.
CDA
C**********************************************************************
CPS
CPS PSEUDOCODE
CPS
CPS BEGIN vgcap_inv
CPS
CPS
CPS END vgcap_inv
CPS
C**********************************************************************

      implicit none

      integer iflg
      real*8 sl
      real*8 slr
      real*8 smr
      real*8 alpha
      real*8 beta

      real*8 ac3
      real*8 ac4
      real*8 bc3
      real*8 bc4
      real*8 hlcut
      real*8 hucut
	real*8 slcut
	real*8 sucut

      real*8 hp
      real*8 dhp
      real*8 star

      real*8 dslh
      real*8 alamda
      real*8 denom
      real*8 alpi
      real*8 termh1
      real*8 termh2
      real*8 dtermh2h
      real*8 dstarh
      real*8 hpa

      hpa = abs(hp)
      if(iflg.eq.1) then
       if(hpa.gt.hlcut.and.hpa.lt.hucut) then
c      check if within spline cutoffs
         alamda = 1.0-1.0/beta
         denom = smr-slr
         termh1 = (alpha*hpa)**beta
         termh2 = 1.d0/(1.d0+termh1)
         star = (termh2)**alamda
         sl =  star*denom +slr
c  assume beta (vg=n) is > 1
         dtermh2h = -termh2/(1.d0+termh1)*beta*(alpha*hpa)**(beta-1.d0)
     &   *alpha
         dstarh = alamda*(1.d0/termh2)**(1.d0-alamda)*dtermh2h
         dslh = dstarh*denom

       else  if(hpa.le.hlcut) then
c      near sl = 1.0
        sl = (hpa-bc4)/bc3
        dslh = 1.d0/bc3
       else  if(hpa.ge.hucut) then
c      near sl = 0.0
        termh1 = slcut/(hucut-ac4)
	  sl = termh1*(hpa-ac4)
        dslh = termh1
       endif
      else if(iflg.eq.2) then
      endif
      return
      end


C
C******************************NOD_CELL*********************************
C
C   transfer nodal values to dem cell values taking into account
C   coarsening of triangulation (dostep>1)
C
C***********************************************************************
C
      subroutine nod_cell(ncell,nrow,ncol,dostep,ncell_coarse,
     1                   nnod,cell,dem_map,indcelwl,cellcoarse,nodvalue,
     2                   cellvalue,arenod,delta_x,delta_y)

      implicit none
      include 'CATHY.H'
      include 'IOUNITS.H'

      integer nrow,ncol
      integer icell,k,l,ncell,nnod,i,j,icell_coarse,m,n
      integer dostep,ncell_coarse,nonnull
      integer cell(5,*),indcelwl(rowmax,*)
      real*8 delta_x,delta_y
      real*8 cellvalue(maxcel),nodvalue(*),arenod(*)
      real*8 cellcoarse(maxcel)
      REAL*8 dem_map(rowmax,colmax)

      do k=1,nnod
         nodvalue(k)=nodvalue(k)/arenod(k)
      end do

c
c dai nodi alle celle grandi
c
      do icell_coarse=1,ncell_coarse
         cellcoarse(icell_coarse)=0.0d0
         do k=1,4
            cellcoarse(icell_coarse)=cellcoarse(icell_coarse)+
     1                        nodvalue(cell(k,icell_coarse))
         end do
         cellcoarse(icell_coarse)=cellcoarse(icell_coarse)*0.25d0
      end do

ccccd      write(99,*) 'i   cellcoarse(i)'
ccccd      do icell_coarse=1,ncell_coarse
ccccd         write(99,*) icell_coarse,cellcoarse(icell_coarse)
cccccd      end do

c
c dalle celle grandi alle piccole
c
      icell_coarse = 0
      do i=1,nrow,dostep
         do j=1,ncol,dostep
          nonnull=0
          do m=1,dostep
           do n=1,dostep
            if(dem_map(i+m-1,j+n-1).ne.0 .and. i+dostep-1.le.nrow
     &                         .and. j+dostep-1.le.ncol) then
               nonnull=nonnull+1
            end if
           end do
          end do
ccccd          write(99,*) 'i=',i,'j=',j,'nonnull=',nonnull
            if (nonnull.gt.0) then
               icell_coarse = icell_coarse + 1
               do k=1,dostep
                 do l=1,dostep
                  if (dem_map(i+k-1,j+l-1).ne.0) then
                   icell = indcelwl(i+k-1,j+l-1)
cccccd                   write(99,*) 'cella non nulla=',icell
                   cellvalue(icell) = cellcoarse(icell_coarse)*
     1                                delta_x*delta_y*dostep*dostep/
     2                                nonnull
ccccc                   write(99,*)'i=',icell,'cellvalue=',cellvalue(icell)
                  end if
                 end do
               end do
            end if
         end do
      end do

      return

      end


submodule(forlab) forlab_disp
    use forlab_kinds
        real(sp), parameter :: nearzero_sp = 1.0e-10_sp
        real(dp), parameter :: nearzero_dp = 1.0e-10_dp
        real(qp), parameter :: nearzero_qp = 1.0e-10_qp
    character(len=*), parameter :: fmt_r = "( *( g11.4, 1x ) )"
    character(len=*), parameter :: fmt_c = "( *( g11.4, a1, g11.4, a1, 1x ) )"
    interface filter
            module procedure filter_sp
            module procedure filter_dp
            module procedure filter_qp
    end interface
contains

        module procedure disp_rsp0
            if (present(string)) print *, trim(string)
            print fmt_r, filter(x)
            return
        end procedure

        module procedure disp_rsp1
            integer :: i, m

            m = size(x)
            if (present(string)) print *, trim(string)
            print fmt_r, (filter(x(i)), i=1, m)

            return
        end procedure

        module procedure disp_rsp2
            integer :: i, j, m, n

            m = size(A, 1)
            n = size(A, 2)
            if (present(string)) print *, trim(string)
            do i = 1, m
                print fmt_r, (filter(A(i, j)), j=1, n)
            end do
            return
        end procedure

        module procedure disp_rsp3
            integer :: i, dim1, dim2, dim3

            dim1 = size(X, 1)
            dim2 = size(X, 2)
            dim3 = size(X, 3)
            if (present(string)) print *, trim(string)
            if ((.not. present(dim)) .or. (dim .eq. 1)) then
                do i = 1, dim1
                    print *, "Slice ("//num2str(i)//",:,:):"
                    call disp(X(i, :, :))
                end do
            elseif (dim .eq. 2) then
                do i = 1, dim2
                    print *, "Slice (:,"//num2str(i)//",:):"
                    call disp(X(:, i, :))
                end do
            elseif (dim .eq. 3) then
                do i = 1, dim3
                    print *, "Slice (:,:,"//num2str(i)//"):"
                    call disp(X(:, :, i))
                end do
            end if
            return
        end procedure
        module procedure disp_rdp0
            if (present(string)) print *, trim(string)
            print fmt_r, filter(x)
            return
        end procedure

        module procedure disp_rdp1
            integer :: i, m

            m = size(x)
            if (present(string)) print *, trim(string)
            print fmt_r, (filter(x(i)), i=1, m)

            return
        end procedure

        module procedure disp_rdp2
            integer :: i, j, m, n

            m = size(A, 1)
            n = size(A, 2)
            if (present(string)) print *, trim(string)
            do i = 1, m
                print fmt_r, (filter(A(i, j)), j=1, n)
            end do
            return
        end procedure

        module procedure disp_rdp3
            integer :: i, dim1, dim2, dim3

            dim1 = size(X, 1)
            dim2 = size(X, 2)
            dim3 = size(X, 3)
            if (present(string)) print *, trim(string)
            if ((.not. present(dim)) .or. (dim .eq. 1)) then
                do i = 1, dim1
                    print *, "Slice ("//num2str(i)//",:,:):"
                    call disp(X(i, :, :))
                end do
            elseif (dim .eq. 2) then
                do i = 1, dim2
                    print *, "Slice (:,"//num2str(i)//",:):"
                    call disp(X(:, i, :))
                end do
            elseif (dim .eq. 3) then
                do i = 1, dim3
                    print *, "Slice (:,:,"//num2str(i)//"):"
                    call disp(X(:, :, i))
                end do
            end if
            return
        end procedure
        module procedure disp_rqp0
            if (present(string)) print *, trim(string)
            print fmt_r, filter(x)
            return
        end procedure

        module procedure disp_rqp1
            integer :: i, m

            m = size(x)
            if (present(string)) print *, trim(string)
            print fmt_r, (filter(x(i)), i=1, m)

            return
        end procedure

        module procedure disp_rqp2
            integer :: i, j, m, n

            m = size(A, 1)
            n = size(A, 2)
            if (present(string)) print *, trim(string)
            do i = 1, m
                print fmt_r, (filter(A(i, j)), j=1, n)
            end do
            return
        end procedure

        module procedure disp_rqp3
            integer :: i, dim1, dim2, dim3

            dim1 = size(X, 1)
            dim2 = size(X, 2)
            dim3 = size(X, 3)
            if (present(string)) print *, trim(string)
            if ((.not. present(dim)) .or. (dim .eq. 1)) then
                do i = 1, dim1
                    print *, "Slice ("//num2str(i)//",:,:):"
                    call disp(X(i, :, :))
                end do
            elseif (dim .eq. 2) then
                do i = 1, dim2
                    print *, "Slice (:,"//num2str(i)//",:):"
                    call disp(X(:, i, :))
                end do
            elseif (dim .eq. 3) then
                do i = 1, dim3
                    print *, "Slice (:,:,"//num2str(i)//"):"
                    call disp(X(:, :, i))
                end do
            end if
            return
        end procedure
        module procedure disp_csp0

            if (present(string)) print *, trim(string)
            if (imag(x) .ge. 0.0d0) then
                ! print *, num2str(real(x))//" + "//num2str(abs(imag(x)))//"i"
                print fmt_c, filter(real(x)), "+", filter(abs(imag(x))), "i"
            else
                ! print *, num2str(real(x))//" - "//num2str(abs(imag(x)))//"i"
                print fmt_c, filter(real(x)), "-", filter(abs(imag(x))), "i"
            end if
            return
        end procedure

        module procedure disp_csp1
            integer :: i, m

            m = size(x)
            if (present(string)) print *, trim(string)
            do i = 1, m
                call disp_csp0(x(i))
            end do
            return
        end procedure

        module procedure disp_csp2
            integer :: i, j, m, n
            m = size(A, 1)
            n = size(A, 2)
            if (present(string)) print *, trim(string)
            do i = 1, m
                do j = 1, n
                    call disp_csp0(A(i, j))
                end do
                print *, ''
            end do
            return
        end procedure
        module procedure disp_cdp0

            if (present(string)) print *, trim(string)
            if (imag(x) .ge. 0.0d0) then
                ! print *, num2str(real(x))//" + "//num2str(abs(imag(x)))//"i"
                print fmt_c, filter(real(x)), "+", filter(abs(imag(x))), "i"
            else
                ! print *, num2str(real(x))//" - "//num2str(abs(imag(x)))//"i"
                print fmt_c, filter(real(x)), "-", filter(abs(imag(x))), "i"
            end if
            return
        end procedure

        module procedure disp_cdp1
            integer :: i, m

            m = size(x)
            if (present(string)) print *, trim(string)
            do i = 1, m
                call disp_cdp0(x(i))
            end do
            return
        end procedure

        module procedure disp_cdp2
            integer :: i, j, m, n
            m = size(A, 1)
            n = size(A, 2)
            if (present(string)) print *, trim(string)
            do i = 1, m
                do j = 1, n
                    call disp_cdp0(A(i, j))
                end do
                print *, ''
            end do
            return
        end procedure
        module procedure disp_cqp0

            if (present(string)) print *, trim(string)
            if (imag(x) .ge. 0.0d0) then
                ! print *, num2str(real(x))//" + "//num2str(abs(imag(x)))//"i"
                print fmt_c, filter(real(x)), "+", filter(abs(imag(x))), "i"
            else
                ! print *, num2str(real(x))//" - "//num2str(abs(imag(x)))//"i"
                print fmt_c, filter(real(x)), "-", filter(abs(imag(x))), "i"
            end if
            return
        end procedure

        module procedure disp_cqp1
            integer :: i, m

            m = size(x)
            if (present(string)) print *, trim(string)
            do i = 1, m
                call disp_cqp0(x(i))
            end do
            return
        end procedure

        module procedure disp_cqp2
            integer :: i, j, m, n
            m = size(A, 1)
            n = size(A, 2)
            if (present(string)) print *, trim(string)
            do i = 1, m
                do j = 1, n
                    call disp_cqp0(A(i, j))
                end do
                print *, ''
            end do
            return
        end procedure

    module procedure disp_l0
        if (present(string)) print *, trim(string)
        print fmt_r, x
        return
    end procedure

    module procedure disp_l1
        integer :: i, m
        m = size(x)
        if (present(string)) print *, trim(string)
        print fmt_r, (x(i), i=1, m)
        return
    end procedure disp_l1

    module procedure disp_l2
        integer :: i, j, m, n
        m = size(A, 1)
        n = size(A, 2)
        if (present(string)) print *, trim(string)
        do i = 1, m
            print fmt_r, (A(i, j), j=1, n)
        end do
        return
    end procedure disp_l2

        module procedure disp_iint80
            if (present(string)) print *, trim(string)
            print fmt_r, x
            return
        end procedure

        module procedure disp_iint81
            integer :: i, m
            m = size(x)
            if (present(string)) print *, trim(string)
            print fmt_r, (x(i), i=1, m)
            return
        end procedure

        module procedure disp_iint82
            integer :: i, j, m, n
            m = size(A, 1)
            n = size(A, 2)
            if (present(string)) print *, trim(string)
            do i = 1, m
                print *, (A(i, j), j=1, n)
            end do
            return
        end procedure

        module procedure disp_iint83
            integer :: i, dim1, dim2, dim3
            dim1 = size(X, 1)
            dim2 = size(X, 2)
            dim3 = size(X, 3)
            if (present(string)) print *, trim(string)
            if ((.not. present(dim)) .or. (dim .eq. 1)) then
                do i = 1, dim1
                    print *, "Slice ("//num2str(i)//",:,:):"
                    call disp(X(i, :, :))
                end do
            elseif (dim .eq. 2) then
                do i = 1, dim2
                    print *, "Slice (:,"//num2str(i)//",:):"
                    call disp(X(:, i, :))
                end do
            elseif (dim .eq. 3) then
                do i = 1, dim3
                    print *, "Slice (:,:,"//num2str(i)//"):"
                    call disp(X(:, :, i))
                end do
            end if
            return
        end procedure
        module procedure disp_iint160
            if (present(string)) print *, trim(string)
            print fmt_r, x
            return
        end procedure

        module procedure disp_iint161
            integer :: i, m
            m = size(x)
            if (present(string)) print *, trim(string)
            print fmt_r, (x(i), i=1, m)
            return
        end procedure

        module procedure disp_iint162
            integer :: i, j, m, n
            m = size(A, 1)
            n = size(A, 2)
            if (present(string)) print *, trim(string)
            do i = 1, m
                print *, (A(i, j), j=1, n)
            end do
            return
        end procedure

        module procedure disp_iint163
            integer :: i, dim1, dim2, dim3
            dim1 = size(X, 1)
            dim2 = size(X, 2)
            dim3 = size(X, 3)
            if (present(string)) print *, trim(string)
            if ((.not. present(dim)) .or. (dim .eq. 1)) then
                do i = 1, dim1
                    print *, "Slice ("//num2str(i)//",:,:):"
                    call disp(X(i, :, :))
                end do
            elseif (dim .eq. 2) then
                do i = 1, dim2
                    print *, "Slice (:,"//num2str(i)//",:):"
                    call disp(X(:, i, :))
                end do
            elseif (dim .eq. 3) then
                do i = 1, dim3
                    print *, "Slice (:,:,"//num2str(i)//"):"
                    call disp(X(:, :, i))
                end do
            end if
            return
        end procedure
        module procedure disp_iint320
            if (present(string)) print *, trim(string)
            print fmt_r, x
            return
        end procedure

        module procedure disp_iint321
            integer :: i, m
            m = size(x)
            if (present(string)) print *, trim(string)
            print fmt_r, (x(i), i=1, m)
            return
        end procedure

        module procedure disp_iint322
            integer :: i, j, m, n
            m = size(A, 1)
            n = size(A, 2)
            if (present(string)) print *, trim(string)
            do i = 1, m
                print *, (A(i, j), j=1, n)
            end do
            return
        end procedure

        module procedure disp_iint323
            integer :: i, dim1, dim2, dim3
            dim1 = size(X, 1)
            dim2 = size(X, 2)
            dim3 = size(X, 3)
            if (present(string)) print *, trim(string)
            if ((.not. present(dim)) .or. (dim .eq. 1)) then
                do i = 1, dim1
                    print *, "Slice ("//num2str(i)//",:,:):"
                    call disp(X(i, :, :))
                end do
            elseif (dim .eq. 2) then
                do i = 1, dim2
                    print *, "Slice (:,"//num2str(i)//",:):"
                    call disp(X(:, i, :))
                end do
            elseif (dim .eq. 3) then
                do i = 1, dim3
                    print *, "Slice (:,:,"//num2str(i)//"):"
                    call disp(X(:, :, i))
                end do
            end if
            return
        end procedure
        module procedure disp_iint640
            if (present(string)) print *, trim(string)
            print fmt_r, x
            return
        end procedure

        module procedure disp_iint641
            integer :: i, m
            m = size(x)
            if (present(string)) print *, trim(string)
            print fmt_r, (x(i), i=1, m)
            return
        end procedure

        module procedure disp_iint642
            integer :: i, j, m, n
            m = size(A, 1)
            n = size(A, 2)
            if (present(string)) print *, trim(string)
            do i = 1, m
                print *, (A(i, j), j=1, n)
            end do
            return
        end procedure

        module procedure disp_iint643
            integer :: i, dim1, dim2, dim3
            dim1 = size(X, 1)
            dim2 = size(X, 2)
            dim3 = size(X, 3)
            if (present(string)) print *, trim(string)
            if ((.not. present(dim)) .or. (dim .eq. 1)) then
                do i = 1, dim1
                    print *, "Slice ("//num2str(i)//",:,:):"
                    call disp(X(i, :, :))
                end do
            elseif (dim .eq. 2) then
                do i = 1, dim2
                    print *, "Slice (:,"//num2str(i)//",:):"
                    call disp(X(:, i, :))
                end do
            elseif (dim .eq. 3) then
                do i = 1, dim3
                    print *, "Slice (:,:,"//num2str(i)//"):"
                    call disp(X(:, :, i))
                end do
            end if
            return
        end procedure

        module function filter_sp(x)
            !! Filter near-zero. Note: elemental
            real(sp), intent(in) :: x
            real(sp) :: filter_sp
            filter_sp = x
            if (abs(x) < nearzero_sp) filter_sp = 0.0
        end function

        module function filter_dp(x)
            !! Filter near-zero. Note: elemental
            real(dp), intent(in) :: x
            real(dp) :: filter_dp
            filter_dp = x
            if (abs(x) < nearzero_dp) filter_dp = 0.0
        end function

        module function filter_qp(x)
            !! Filter near-zero. Note: elemental
            real(qp), intent(in) :: x
            real(qp) :: filter_qp
            filter_qp = x
            if (abs(x) < nearzero_qp) filter_qp = 0.0
        end function

    module procedure disp_str
        if (present(string)) then
            print *, trim(string)
        else
            print *, ''
        end if
        return
    end procedure
end submodule


      subroutine initrandom(inpseed)
      implicit none
      integer :: inpseed
      integer :: iseedsize,n,i
      integer, dimension(:), allocatable :: iputarray
! determine the seed size and allocate the seed array:
      call random_seed(size=iseedsize)
      allocate(iputarray(iseedsize))
! set a unique seed for each proc:
      n=inpseed
      do i=1,iseedsize
        n=mod(9301*n+49297,233280)
        iputarray(i)=n
      enddo
      call random_seed(put=iputarray)
      return
      end subroutine initrandom


C$Procedure WNCARD ( Cardinality of a double precision window )

      INTEGER FUNCTION WNCARD ( WINDOW )

C$ Abstract
C
C     Return the cardinality (number of intervals) of a double
C     precision window.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     WINDOWS
C
C$ Keywords
C
C     WINDOWS
C
C$ Declarations

      INTEGER               LBCELL
      PARAMETER           ( LBCELL = -5 )

      DOUBLE PRECISION      WINDOW  ( LBCELL:* )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     WINDOW     I   Input window.
C
C     The function returns the cardinality of the input window.
C
C$ Detailed_Input
C
C      WINDOW      is a window containing zero or more intervals.
C
C$ Detailed_Output
C
C     The function returns the cardinality of (number of intervals in)
C     the input window.
C
C$ Parameters
C
C      None.
C
C$ Exceptions
C
C     1) If the number of elements in WINDOW is not even
C        the error SPICE(INVALIDSIZE) signals.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The window cardinality (WNCARD) function simply wraps a CARD call
C     then divides the result by 2. A common error when using the SPICE
C     windows function is to use the CARDD value as the number of
C     window intervals rather than the CARDD/2 value.
C
C$ Examples
C
C      INTEGER               LBCELL
C      PARAMETER           ( LBCELL = -5 )
C
C      INTEGER               WNSIZE
C      PARAMETER           ( WNSIZE = 10 )
C
C      DOUBLE PRECISION      WINDOW      ( LBCELL:WNSIZE )
C      DOUBLE PRECISION      LEFT
C      DOUBLE PRECISION      RIGHT
C
C      INTEGER               WNCARD
C      INTEGER               I
C
C      Validate the window with size WNSIZE and zero elements.
C
C      CALL WNVALD( WNSIZE, 0, WINDOW )
C
C      Insert the intervals
C
C         [ 1, 3 ]  [ 7, 11 ]  [ 23, 27 ]
C
C      into WINDOW.
C
C      CALL WNINSD(  1.D0,  3.D0, WINDOW )
C      CALL WNINSD(  7.D0, 11.D0, WINDOW )
C      CALL WNINSD( 23.D0, 27.D0, WINDOW )
C
C      Loop over the number of intervals in WINDOW, output
C      the LEFT and RIGHT endpoints for each interval.
C
C      DO I=1, WNCARD(WINDOW)
C
C         CALL WNFETD( WINDOW, I, LEFT, RIGHT )
C
C         WRITE(*,*) 'Interval', I, ' [', LEFT, RIGHT, ']'
C
C      END DO
C
C   The code outputs:
C
C      Interval 1 [  1.    3.]
C      Interval 2 [  7.   11.]
C      Interval 3 [  23.  27.]
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     E.D. Wright    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 24-APR-2010 (EDW)
C
C       Minor edit to code comments eliminating typo.
C
C-    SPICELIB Version 1.0.0, 10-AUG-2007 (EDW)
C
C-&

C$ Index_Entries
C
C     cardinality of a d.p. window
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
      LOGICAL               EVEN

      INTEGER               CARDD

      IF ( RETURN() ) THEN
         WNCARD = 0
         RETURN
      ELSE
         CALL CHKIN ( 'WNCARD' )
      END IF

      WNCARD = CARDD(WINDOW)

C
C     Confirm the cardinality as an even integer.
C
      IF( .NOT. EVEN(WNCARD) ) THEN

         CALL SETMSG ( 'Invalid window size, a window should '
     .        // 'have an even number of elements. The size was #.')
         CALL ERRINT ( '#', WNCARD )
         CALL SIGERR ( 'SPICE(INVALIDSIZE)' )
         CALL CHKOUT ( 'WNCARD' )
         WNCARD = 0
         RETURN

      END IF

C
C     Set return value. Cardinality in a SPICE window sense
C     means the number of intervals, half the cell
C     cardinality value.
C
      WNCARD = WNCARD/2

      CALL CHKOUT ( 'WNCARD' )
      RETURN
      END


! { dg-do compile }
! PR 33689
! Wrongly rejected valid code due to non-trivial expression for array bound
 subroutine grylmr()
    integer, parameter :: lmaxd = 20
    REAL, save :: c(0:(lmaxd+1)*(lmaxd+1))
  end subroutine grylmr
end


!----------------------------------------
subroutine gradke(ke, du, l, m, n)
  !
  ! du += -delta[ ke ]
  ! where delta[ ] is the finite difference in the 'u' direction
  ! the 'u' direction is the third entry of the 3D array
  !
  implicit none

  integer, intent(in):: l, m, n
  real*8, dimension(l, m, n), intent(in) :: ke
  real*8, dimension(l, m, n), intent(inout) :: du

  !f2py intent(inplace):: ke, du

  integer:: i, j, k

  do k = 1, l
     do j = 1, m
        do i = 1, n-1
           du(k,j,i) = du(k,j,i) - (ke(k,j,i+1)-ke(k,j,i))
        enddo
     enddo
  enddo

end subroutine gradke

!----------------------------------------
subroutine gradkeandb(ke, b, du, dz, l, m, n)
  !
  ! du += -delta[ ke ] + b*dz
  ! where delta[ ] is the finite difference in the 'u' direction
  ! the 'u' direction is the third entry of the 3D array
  !
  implicit none

  integer, intent(in):: l, m, n
  real*8:: dz
  real*8, dimension(l, m, n), intent(in) :: ke, b
  real*8, dimension(l, m, n), intent(inout) :: du

  !f2py intent(inplace):: ke, b, du

  integer:: i, j, k
  real*8:: cff

  cff = 0.5*dz

  do k = 1, l
     do j = 1, m
        do i = 1, n-1
           du(k,j,i) = du(k,j,i) - (ke(k,j,i+1)-ke(k,j,i)) &
                + cff*(b(k,j,i+1)+b(k,j,i))
        enddo
     enddo
  enddo

end subroutine gradkeandb

!----------------------------------------
subroutine div(d, u, iflag, l, m, n)
  !
  ! d += delta[ u ]
  ! where delta[ ] is the LEFT finite difference in the 'u' direction
  ! the 'u' direction is the third entry of the 3D array
  !
  implicit none

  integer, intent(in):: l, m, n, iflag
  real*8, dimension(l, m, n), intent(inout) :: d
  real*8, dimension(l, m, n), intent(in) :: u

  !f2py intent(inplace):: d, u

  integer:: i, j, k

  if (iflag.gt.0) then
     do k = 1, l
        do j = 1, m
           d(k,j,1) = d(k,j,1) + u(k,j,1)
           do i = 2, n
              d(k,j,i) = d(k,j,i) + (u(k,j,i)-u(k,j,i-1))
           enddo
        enddo
     enddo
  else
     do k = 1, l
        do j = 1, m
           d(k,j,1) = u(k,j,1)
           do i = 2, n
              d(k,j,i) = (u(k,j,i)-u(k,j,i-1))
           enddo
        enddo
     enddo
  endif

end subroutine div


program swap_test
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none
    integer, parameter :: nr_vals = 100000, nr_steps = 10000
    real :: start_time, end_time
    real, dimension(:), allocatable :: orig_vector, vector
    real, dimension(:), allocatable, target ::  old_vector, new_vector
    real, dimension(:), pointer :: old_vector_p, new_vector_p
    integer :: step, istat

    allocate (orig_vector(nr_vals), vector(nr_vals), old_vector(nr_vals), &
              new_vector(nr_vals), stat=istat)

    ! initialize data
    call random_number(orig_vector)
    print '(A, E15.7)', 'original: ', sum(orig_vector)

    call cpu_time(start_time)
    vector = orig_vector
    do step = 1, nr_steps
        call compute_kernel_tmp(vector)
    end do
    call cpu_time(end_time)
    print '(A20, F12.6, E15.7)', 'copy swap: ', end_time - start_time, sum(vector)

    old_vector = orig_vector
    old_vector_p => old_vector
    new_vector_p => new_vector
    call cpu_time(start_time)
    do step = 1, nr_steps
        call compute_kernel_pointers(new_vector_p, old_vector_p)
        call swap_pointers(old_vector_p, new_vector_p)
    end do
    call cpu_time(end_time)
    if (mod(nr_steps, 2) == 0) then
        print '(A20, F12.6, E15.7)', 'pointer swap: ', end_time - start_time, &
            sum(old_vector)
    else
        print '(A20, F12.6, E15.7)', 'pointer swap: ', end_time - start_time, &
            sum(new_vector)
    end if

    ! check results
    if (mod(nr_steps, 2) == 0) then
        if (any(abs(vector - old_vector) > epsilon(1.0))) &
            write (unit=error_unit, fmt='(A)') 'warning: results differ'
    else
        if (any(abs(vector - new_vector) > epsilon(1.0))) &
            write (unit=error_unit, fmt='(A)') 'warning: results differ'
    end if

    old_vector = orig_vector
    call cpu_time(start_time)
    do step = 1, nr_steps
        if (mod(step, 2) == 1) then
            call compute_kernel_pointers(new_vector, old_vector)
        else
            call compute_kernel_pointers(old_vector, new_vector)
        end if
    end do
    call cpu_time(end_time)
    if (mod(nr_steps, 2) == 0) then
        print '(A20, F12.6, E15.7)', 'juggle swap: ', end_time - start_time, &
            sum(old_vector)
    else
        print '(A20, F12.6, E15.7)', 'juggle swap: ', end_time - start_time, &
            sum(new_vector)
    end if

    ! check results
    if (mod(nr_steps, 2) == 0) then
        if (any(abs(vector - old_vector) > epsilon(1.0))) &
            write (unit=error_unit, fmt='(A)') 'warning: results differ'
    else
        if (any(abs(vector - new_vector) > epsilon(1.0))) &
            write (unit=error_unit, fmt='(A)') 'warning: results differ'
    end if

    deallocate (orig_vector, vector, new_vector, old_vector)

contains

    subroutine compute_kernel_tmp(vector)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        real, dimension(:), intent(inout) :: vector
        real, dimension(:), allocatable :: tmp_vector
        integer :: i, istat

        allocate (tmp_vector(size(vector)), stat=istat)
        if (istat /= 0) then
            write (unit=error_unit, fmt='(A)') 'error: can not allocate tmp_vector'
            stop 1
        end if
        tmp_vector(1) = vector(1)
        tmp_vector(size(vector)) = vector(size(vector))
        do i = 2, size(vector) - 1
            tmp_vector(i) = 0.25*(vector(i - 1) + vector(i + 1)) + 0.5*vector(i)
        end do
        vector = tmp_vector
        deallocate (tmp_vector)
    end subroutine compute_kernel_tmp

    subroutine compute_kernel_pointers(new_vector, old_vector)
        implicit none
        real, dimension(:), intent(inout) :: new_vector, old_vector
        integer :: i

        new_vector(1) = old_vector(1)
        new_vector(size(old_vector)) = old_vector(size(old_vector))
        do i = 2, size(old_vector) - 1
            new_vector(i) = 0.25*(old_vector(i - 1) + old_vector(i + 1)) + &
                0.5*old_vector(i)
        end do
    end subroutine compute_kernel_pointers

    subroutine swap_pointers(a, b)
        implicit none
        real, dimension(:), pointer, intent(inout) :: a, b
        real, dimension(:), pointer :: tmp

        tmp => a
        a => b
        b => tmp
    end subroutine swap_pointers

end program swap_test


!     Example p.4 Khadija Imadoueddine: matrix multiply
!
!     The k loop must be moved inside

!     But it is not parallel, which PIPS does not detect (wrong code is
!     generated) This should lead to some register tiling
!
!     Legality of interchange is not ested either

      subroutine interchange(n, a, b, c)
      integer n, i, j, k
      real a(1:n,1:n), b(1:n,1:n), c(1:n,1:n)

      do 300 k = 1, n
         do 200 j = 1, n
            do 100 i = 1, n
               c(i,j) = c(i,j) + a(i,k)*b(k,j)
 100        continue
 200     continue
 300  continue

      end


C    @(#)qiksrt.f	20.3 2/13/96
        subroutine qiksrt(mm, nn, kompar, swap)
        external kompar, swap
C
C       Algorithm 271 (QUICKERSORT BY R.S. SCOWEN,)
C               MAR. 1965 COMMUNICATIONS OF THE ACM
C
C
C       This procedure uses a method similar to that of QUICKSORT.
C       by C.A.R. Hoare (Algorithms 63,64, COMM.ACM 4 JULY 1961)
C
C       Modified to use shell sort on partitions of 15 or less.
C               (1/18/79 by A.H. Schmidt,Jr.)
C
        dimension mstack(20), nstack(20)
        logical sorted, exchg, cont, cont1, cont2
C
        m=mm
        n=nn
        sorted=.false.
        level=0
C
C       REPEAT-UNTIL(SORTED) PARTITION-AND-SORT
C
        do while (.not.sorted)
C
C          TO PARTITION-AND-SORT
C
           num=n-m+1
C
           if (num .gt. 15) then

C             PARTITION-THE-ARRAY
C
              i = m
              j = n
              k = (m + n) / 2
C
              do while (i .lt. j)
C
C                LOCATE ITEM AT I END THAT SHOULD GO TO J END

                 cont = .true.
                 do while (i .lt. n .and. cont)
                    if (kompar(i,k) .le. 0) then
                       i = i + 1
                    else
                       cont = .false.
                    endif
                 enddo
C
C                LOCATE ITEM AT J END THAT SHOULD GO TO I END
C
                 cont = .true.
                 do while (j .gt. m .and. cont)
                    if (kompar(j,k) .ge. 0) then
                       j = j - 1
                    else
                       cont = .false.
                    endif
                 enddo
C
C                SWAP MISPOSITIONED ITEMS
C
                 if (i .lt. j) then
                    call swap(i,j)
                    j = j - 1
                    i = i + 1

                 else if (i .lt. k) then
                    call swap (i,k)
                    i = i + 1

                 else if (j .gt. k) then
                    call swap (j,k)
                    j = j - 1

                 endif
              enddo

C             PUSH-LARGEST-PARTITION-ON-STACK
C
              level = level + 1

              if (j-m .lt. n-i) then
                 mstack(level) = i
                 nstack(level) = n
                 n = j

              else
                 mstack(level) = m
                 nstack(level) = j
                 m = i

              endif

           else

C             SHELL-SORT-PARTITION-OF-15-OR-LESS

              do while (num .gt. 1)
                 num = num / 2
                 k = n - num
                 j = m
                 cont1 = .true.
                 do while (cont1)
                    i = j
                    cont2 = .true.
                    do while (cont2)
                       exchg = .false.
                       if (kompar(i,i+num) .gt. 0) then
                          call swap(i,i+num)
                          exchg = .true.
                          i = i - num
                       endif
                       cont2 = (exchg .and. i .ge. m)
                    enddo
                    j = j + 1
                    cont1 = (j .le. k)
                 enddo
              enddo

              if (level .gt. 0) then

C                POP-NEXT-PORTION-FROM-STACK

                 m = mstack(level)
                 n = nstack(level)
                 level = level - 1
              else
                 sorted = .true.
              endif
           endif
        enddo
        return
        end


C     Sorts an array arr(1:N) into ascending numerical order
C      using the QuickSort algorithm.  On output arr is replaced with its
C      sorted rearrangement.
      SUBROUTINE DQSORT(N,ARR)
      INTEGER N,M,NSTACK
      REAL*8 ARR(N)
      PARAMETER (M=7, NSTACK=100)
      INTEGER I, IR, J, JSTACK, K, L, ISTACK(NSTACK)
      REAL*8 A, TEMP

      JSTACK = 0
      L = 1
      IR = N
 1    IF(IR-L.LT.M)THEN
         DO  J=L+1,IR
            A = ARR(J)
            DO I = J-1,L,-1
               IF (ARR(I).LE.A) GOTO 2
               ARR(I+1)=ARR(I)
            ENDDO
            I = L-1
 2          ARR(I+1) = A
         ENDDO

         IF(JSTACK.EQ.0)RETURN
         IR=ISTACK(JSTACK)
         L=ISTACK(JSTACK-1)
         JSTACK = JSTACK - 2

      ELSE
         K = (L+IR)/2
         TEMP = ARR(K)
         ARR(K) = ARR(L+1)
         ARR(L+1) = TEMP
         IF(ARR(L).GT.ARR(IR))THEN
            TEMP = ARR(L)
            ARR(L) = ARR(IR)
            ARR(IR) = TEMP
         ENDIF
         IF(ARR(L+1).GT.ARR(IR))THEN
            TEMP=ARR(L+1)
            ARR(L+1)=ARR(IR)
            ARR(IR)=TEMP
         ENDIF
         IF(ARR(L).GT.ARR(L+1))THEN
            TEMP=ARR(L)
            ARR(L) = ARR(L+1)
            ARR(L+1) = TEMP
         ENDIF

         I=L+1
         J=IR
         A=ARR(L+1)
 3       CONTINUE
             I=I+1
         IF(ARR(I).LT.A)GOTO 3
 4       CONTINUE
             J=J-1
         IF(ARR(J).GT.A)GOTO 4
         IF(J.LT.I)GOTO 5
         TEMP = ARR(I)
         ARR(I) = ARR(J)
         ARR(J) = TEMP
         GOTO 3
 5       ARR(L+1) = ARR(J)
         ARR(J) = A
         JSTACK = JSTACK + 2
         IF(JSTACK.GT.NSTACK)RETURN
         IF(IR-I+1.GE.J-1)THEN
            ISTACK(JSTACK)=IR
            ISTACK(JSTACK-1)=I
            IR=J-1
         ELSE
            ISTACK(JSTACK)=J-1
            ISTACK(JSTACK-1)=L
            L=I
         ENDIF
      ENDIF
      GOTO 1
      END

C     Finds repeated elements of ARR and their occurrence incidence
C     reporting the result in REPLIST and REPNUM respectively.
C     NLIST is the number of repeated elements found.
C     Algorithm first sorts the list and then walks down it
C       counting repeats as they are found.
      SUBROUTINE DFREPS(ARR,N,REPLIST,REPNUM,NLIST)
      REAL*8 REPLIST(N), ARR(N)
      REAL*8 LASTVAL
      INTEGER REPNUM(N)
      INTEGER HOWMANY, REPEAT, IND, NLIST, NNUM

      CALL DQSORT(N,ARR)
      LASTVAL = ARR(1)
      HOWMANY = 0
      IND = 2
      NNUM = 1
      NLIST = 1
      REPEAT = 0
      DO WHILE(IND.LE.N)
         IF(ARR(IND).NE.LASTVAL)THEN
            IF (REPEAT.EQ.1)THEN
               REPNUM(NNUM)=HOWMANY+1
               NNUM=NNUM+1
               REPEAT=0
               HOWMANY=0
            ENDIF
         ELSE
            HOWMANY=HOWMANY+1
            REPEAT=1
            IF(HOWMANY.EQ.1)THEN
               REPLIST(NLIST)=ARR(IND)
               NLIST=NLIST+1
            ENDIF
         ENDIF
         LASTVAL=ARR(IND)
         IND=IND+1
      ENDDO
      IF(REPEAT.EQ.1)THEN
         REPNUM(NNUM)=HOWMANY+1
      ENDIF
      NLIST = NLIST - 1
      END


      SUBROUTINE COMUGV
C
C FOR DDAM/EARTHQUAKE ANALYSES, COMBUGV COMBINES DISPLACEMENT
C COMPONENTS BY (1)ADDING THE COMPONENTS IN ABS VALUE AND (2)TAKING THE
C SQUARE ROOT OF THE SUMS OF THE SQUARES. AFTER THIS MODEULE, THE
C TWO OUTPUT DATA BLOCKS ARE N X NMODES, WHEREAS UGV IS N X (NMODES)(L)
C MODULE NRLSUM COMBINES STRESSES ACROSS MODES FOR EACH DIRECTION
C INDIVIDUALLY. THE OUTPUTS OF THIS MODULE HAVE THE DIRECTIONS
C COMBINED. BUT NRLSUM CAN WORK ON THEM (AFTER CASEGEN AND SDR2) BY
C SPECIFYING NDIR=1 IN THE DMAP STATEMENT FOR THOSE MODULES.
C THIS MODULE WILL ALSO COMBINE THE MAXIMUM RESPONSES ACROSS THE MODES
C BY USING SQRSS TO COME UP WITH ONE RESPONSE VECTOR. THEREFORE THIS
C MODULE COMBINES COMPONENTS TO GET MAXIMUM RESPONSES BY ADDING (UGVADD)
C AND BY SQRSS (UGVSQR). THEN IT TAKES EACH OF THESE AND TAKES SQRSS
C ACROSS THE MODES TO GET UGVADC AND UGVSQC, RESPECTIVELY.
C FINALLY, THE MODULE COMPUTES THE NRL SUMS FOR THE L DIRECTIONS
C TO USE CASEGEN,SDR2,ETC. ON UGVADC AND UGVSQC, IN CASEGEN,USE
C LMODES=NDIR=1 IN DMAP STATEMENT. FOR UGVNRL, JUST USE LMODES=1.
C
C COMBUGV UGV/UGVADD,UGVSQR,UGVADC,UGVSQC,UGVNRL/V,N,NMODES/V,N,NDIR $
C
      INTEGER BUF1,BUF2,BUF3,UGV,UGVADD,UGVSQR,UGVADC,UGVSQC
      INTEGER UGVNRL
      INTEGER INDB(2),OUDB(2)
      DIMENSION NAM(2),MCB(7),MCB1(7),MCB2(7)
      COMMON/UNPAKX/JOUT,III,NNN,JNCR
      COMMON/PACKX/IIN,IOUT,II,NN,INCR
      COMMON/SYSTEM/IBUF
      COMMON/BLANK/NMODES,NDIR
      COMMON/ZZZZZZ/Z(1)
      DATA UGV,UGVADD,UGVSQR,UGVADC,UGVSQC/101,201,202,203,204/
      DATA UGVNRL/205/
      DATA NAM/4HCOMB,4HUGV /
C
C OPEN CORE AND BUFFERS
C
      LCORE=KORSZ(Z)
      BUF1=LCORE-IBUF+1
      BUF2=BUF1-IBUF
      BUF3=BUF2-IBUF
      LCORE=BUF3-1
      IF(LCORE.LE.0)GO TO 1008
      MCB(1)=UGV
      CALL RDTRL(MCB)
      NCOL=MCB(2)
      NROW=MCB(3)
      IF(NCOL.NE.NMODES*NDIR)GO TO 1007
      IF(LCORE.LT.4*NROW)GO TO 1008
      MCB1(1)=UGVADD
      MCB1(2)=0
      MCB1(3)=NROW
      MCB1(4)=2
      MCB1(5)=1
      MCB1(6)=0
      MCB1(7)=0
      MCB2(1)=UGVSQR
      MCB2(2)=0
      MCB2(3)=NROW
      MCB2(4)=2
      MCB2(5)=1
      MCB2(6)=0
      MCB2(7)=0
C
      JOUT=1
      III=1
      NNN=NROW
      JNCR=1
      IIN=1
      IOUT=1
      II=1
      NN=NROW
      INCR=1
C
      CALL GOPEN(UGV,Z(BUF1),0)
      CALL GOPEN(UGVADD,Z(BUF2),1)
      CALL GOPEN(UGVSQR,Z(BUF3),1)
C
C UNPACK NDIR COLUMNS OF UGV WHICH CORRESPOND TO A SINGLE MODE
C
      NM1=NMODES-1
      ND1=NDIR-1
      DO 120 I=1,NMODES
C
C POINTER TO PROPER MODE IN 1ST DIRECTION
C
      NSKIP=I-1
      IF(NSKIP.EQ.0)GO TO 20
      DO 10 LL=1,NSKIP
      CALL FWDREC (*1002,UGV)
   10 CONTINUE
C
C UNPACK VECTOR
C
   20 CALL UNPACK (*25,UGV,Z(1))
      GO TO 40
C
   25 DO 30 J=1,NROW
   30 Z(J)=0.
C
C SKIP TO NEW DIRECTION, UNPACK, SKIP AND UNAPCK
C
   40 IF(ND1.EQ.0)GO TO 100
      DO 70 J=1,ND1
      IF(NM1.EQ.0)GO TO 50
      DO 45 JJ=1,NM1
      CALL FWDREC (*1002,UGV)
   45 CONTINUE
C
   50 JNROW = J*NROW
      CALL UNPACK (*55,UGV,Z(JNROW+1))
      GO TO 70
   55 DO 60 JJ=1,NROW
   60 Z(J*NROW+JJ)=0.
C
   70 CONTINUE
C
C NOW PERFORM EACH OPERATION AND STORE INTO Z(3*NROW+1)
C
      DO 80 KK=1,NROW
      Z(3*NROW+KK)=ABS(Z(KK))+ABS(Z(NROW+KK))+ABS(Z(2*NROW+KK))
   80 CONTINUE
      CALL PACK(Z(3*NROW+1),UGVADD,MCB1)
C
      DO 90 KK=1,NROW
      Z(3*NROW+KK)=SQRT(Z(KK)**2+Z(NROW+KK)**2+Z(2*NROW+KK)**2)
   90 CONTINUE
      CALL PACK(Z(3*NROW+1),UGVSQR,MCB2)
      GO TO 110
C
C JUST ONE DIRECTION ON UGV- COPY TO DATA BLOCKS
C
  100 CALL PACK(Z(1),UGVADD,MCB1)
      CALL PACK(Z(1),UGVSQR,MCB2)
C
C DONE FOR THIS MODE - GET ANOTHER
C
  110 CALL REWIND(UGV)
      CALL FWDREC (*1002,UGV)
C
  120 CONTINUE
C
      CALL CLOSE(UGVADD,1)
      CALL CLOSE(UGVSQR,1)
      CALL WRTTRL(MCB1)
      CALL WRTTRL(MCB2)
C
C NOW COMPUTE NRL SUMS FOR THE L DIRECTIONS
C
      MCB1(1)=UGVNRL
      MCB1(2)=0
      MCB1(3)=NROW
      MCB1(4)=2
      MCB1(5)=1
      MCB1(6)=0
      MCB1(7)=0
      CALL REWIND(UGV)
      CALL FWDREC (*1002,UGV)
      CALL GOPEN(UGVNRL,Z(BUF2),1)
C
      DO 1240 ND=1,NDIR
C
C SET UP VECTOR OF MAXIMUM DISPLACEMENT COMPONENTS AND VECTOR OF SUMS
C
      DO 1200 I=1,NROW
      Z(I)=0.
 1200 Z(2*NROW+I)=0.
C
      DO 1220 I=1,NMODES
C
      CALL UNPACK (*1220,UGV,Z(NROW+1))
C
C COMPARE TO MAXIMUM COMPONENTS
C
      DO 1210 J=1,NROW
      IF (ABS(Z(NROW+J)).GT.Z(J))Z(J)=ABS(Z(NROW+J))
      Z(2*NROW+J)=Z(2*NROW+J)+Z(NROW+J)**2
 1210 CONTINUE
C
C GET ANOTHER DISPLACEMENT VECTOR CORRESPONDING TO ANOTHER MODE
C
 1220 CONTINUE
C
C SUBTRACT THE MAXIMA FROM THE SUMS
C
      DO 1230 J=1,NROW
      Z(2*NROW+J)=Z(2*NROW+J)-Z(J)**2
C
C TAKE SQUARE ROOT AND ADD IN THE MAXIMA
C
      Z(2*NROW+J)=SQRT(Z(2*NROW+J))+Z(J)
 1230 CONTINUE
C
C PACK RESULTS ANG GET ANOTHER DIRECTION
C
      CALL PACK(Z(2*NROW+1),UGVNRL,MCB1)
 1240 CONTINUE
C
      CALL CLOSE(UGV,1)
      CALL CLOSE(UGVNRL,1)
      CALL WRTTRL(MCB1)
C
C NOW LETS COMBINE RESPONSES OVER THE MODES USING SQRSS. DO FOR BOTH
C UGVADD AND UGVSQR. THE RESULT WILL BE ONE DISLPACEMENT VECTOR.
C (BOTH UGVADD AND UGVSQR ARE N X M ( M= NO. OF MODES)
C
      INDB(1)=UGVADD
      INDB(2)=UGVSQR
      OUDB(1)=UGVADC
      OUDB(2)=UGVSQC
C
      DO 170 I=1,2
C
      MCB(1)=INDB(I)
      CALL RDTRL(MCB)
      NCOL=MCB(2)
      NROW=MCB(3)
      MCB1(1)=OUDB(I)
      MCB1(2)=0
      MCB1(3)=NROW
      MCB1(4)=2
      MCB1(5)=1
      MCB1(6)=0
      MCB1(7)=0
      IF(NCOL.NE.NMODES)GO TO 1007
C
      CALL GOPEN(INDB(I),Z(BUF1),0)
      CALL GOPEN(OUDB(I),Z(BUF2),1)
C
      DO 130 J=1,NROW
  130 Z(J)=0.
C
C UNPACK THE COLUMNS OF INDB AND ACCUMULATE SUMS OF SQUARES
C
      DO 150 J=1,NMODES
      CALL UNPACK (*150,INDB(I),Z(NROW+1))
C
      DO 140 K=1,NROW
  140 Z(K)=Z(K)+Z(NROW+K)**2
C
  150 CONTINUE
C
      DO 160 K=1,NROW
  160 Z(K)=SQRT(Z(K))
C
      CALL PACK(Z(1),OUDB(I),MCB1)
C
      CALL CLOSE(INDB(I),1)
      CALL CLOSE(OUDB(I),1)
      CALL WRTTRL(MCB1)
C
  170 CONTINUE
C
      RETURN
C
 1002 CALL MESAGE(-2,UGV,NAM)
 1007 CALL MESAGE(-7,0,NAM)
 1008 CALL MESAGE(-8,0,NAM)
      RETURN
      END


program dvopa

  use globals
  use slf_cgs
  use settings, only: rdargvgl, outfn
  use ranges, only: logrange
  use heatbalance, only: fcool2

  implicit none
  real(r64) :: trad, wsp1, wsp2, wsp3
  integer :: un, i, j
  integer, parameter :: n = 256
  real(r64) :: rho(n), T(n) , rho0, cool(n), cool_dr(n), cool_dT(n), cool_p0(n)

  outfn = ""
  call rdargvgl

  write(*, '(a)', advance = 'no') "input T_rad = "
  read(*, *) trad

  write(*, *)

  wsp1 = (8. / 3.) * cgs_kapes / kram0p(abuX, abuZ) * cgs_k_over_mec2 * 1e27_r64
  wsp2 = 4 * cgs_stef * (cgs_kapes * 4 * cgs_k_over_mec2)**2 / kram0p(abuX, abuZ) * 1e57_r64
  write (*, '(a15, 2es9.2)') 'coeff = ', wsp1, wsp1 / cgs_mhydr
  write (*, '(a15, es9.2)') 'coeff2 = ', wsp2
  write (*, '(a15, es9.2)') 'cool0 = ', wsp2 * (Trad / 1e6)**9.5

  rho0 = wsp1 * (trad / 1e6)**4.5
  write (*, '(a15, es9.2)') 'rho0 = ', rho0 / cgs_mhydr
  write (*, '(a15, es9.2)') 'kram0 = ', kram0(abuX, abuZ)
  write (*, '(a15, es9.2)') 'kram0p = ', kram0p(abuX, abuZ)

  call logrange(T, Trad, Trad * 3e4)
  call logrange(rho, rho0 * 3e-5, rho0 * 3e4)

  if (outfn == "") write(outfn, '("cool_logT_", f0.2, ".dat")') log10(trad)
  open(newunit = un, file = outfn, action = 'write')

  write(un, '(i8, 3es12.4)') n, trad, rho0 / cgs_mhydr, wsp2 * (Trad / 1e6)**9.5
  write(un, *)
  write(un, '(*(es12.4))') T(:)
  write(un, '(*(es12.4))') rho(:) / cgs_mhydr

  do j = 1, n
    call fcool2(rho(j), T, trad, cool, cool_dr, cool_dT)
    cool_dr(:) = cool_dr * rho(j) / cool
    cool_dT(:) = cool_dT * T      / cool
    cool_p0(:) = cool_dT - cool_dr
    ! cool = cool / wsp2
    write(un, '("# j =", i4, ", rho =", es12.4)') j, rho(j) / cgs_mhydr
    write(un, '(*(es12.4))') cool
    write(un, '(*(es12.4))') cool_dr
    write(un, '(*(es12.4))') cool_dT
    write(un, '(*(es12.4))') cool_p0
  end do

  close(un)

  write(*, '(a, a)') 'output: ', trim(outfn)

end program


C NCLFORTSTART
      subroutine gammacomplete (nx, xin, xout, has_msg, xmsg)
      implicit none
c                              INPUT
      integer  nx, has_msg
      double precision xin(nx), xmsg
c                              OUTPUT
      double precision xout(nx)
C NCLEND
C NCL: gma = gamma( x )
c WRAPIT -L $NCARG_ROOT/lib -l nfpfort gamma_interface.f
c                              LOCAL
      integer n
      double precision dgammaslatec

      if(has_msg.eq.0) then
        do n=1,nx
          xout(n) = dgammaslatec ( xin(n) )
        end do
      else
        do n=1,nx
           if(xin(n) .ne. xmsg) then
              xout(n) = dgammaslatec ( xin(n) )
           else
              xout(n) = xmsg
           end if
        end do
      endif

      return
      end