C***********************************************************************
C***********************************************************************
C BEGINNING OF FEMPAK
C BEGINNING OF FEMPAK
C***********************************************************************
C***********************************************************************
C
C FEMPAK
C
C***********************************************************************
C***********************************************************************
      SUBROUTINE BASIS1D(nn,zref,zdes,b2,n2,b1,n1)
C-----------------------------------------------------------------------
C purpose: This subroutine evaluates the value of the basis functions 
C            alive on a 1-D linear element at a point
C
C restrictions: Applicable only for  1-D linear elements
C
C inputs:  nn is the number of entries in the reference z array
C          zref(nn) is the 1-D array containing the reference z array
C               NOTE: zref must increase from zref(1) to zref(nn)
C          zdes is the z value at which the basis functions are desired
C
C outputs: n1 is the reference node immediately below zdes
C          b1 is the value of the n1's basis function at zres
C          n2 is the reference node immediately above zdes
C          b2 is the value of the n2's basis function at zres
C
C notes:   zdes<zref(1) => n1=0,b1=0.0,n2=1,b2=1.0 
C          zdes>zref(nn) => n1=nn,b1=1.0,n2=0,b2=0.0 
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           26 AUGUST 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      dimension zref(nn)
C
C START OF EXECUTABLE CODE
      do 10 k=1,nn 
         if(zdes.LT.zref(k))then
C
C if zdes<zref(1), zdes is below the reference data => set b1=n1=0
            n2=k
            n1=k-1
            if(n2.EQ.1)then
                b1=0.0
                b2=1.0
                go to 20
             endif
             zdiff=zref(n2)-zref(n1)
             b1=(zref(n2)-zdes)/zdiff
             b2=(zdes-zref(n1))/zdiff  
             go to 20
         endif
 10   continue
C
C if zdes>zref(nn), zdes is above the reference data => set b2=n2=0
      b1=1.0
      n1=nn
      b2=0.0
      n2=0.0
 20   continue
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
C***********************************************************************
C***********************************************************************
      SUBROUTINE BASIS1D1(nn,zref,zdes,b2,n2,b1,n1)
C-----------------------------------------------------------------------
C purpose: This subroutine evaluates the value of the basis functions 
C            alive on a 1-D linear element at a point
C
C restrictions: Applicable only for  1-D linear elements
C
C inputs:  nn is the number of entries in the reference z array
C          zref(nn) is the 1-D array containing the reference z array
C               NOTE: zref must increase from zref(1) to zref(nn)
C          zdes is the z value at which the basis functions are desired
C
C outputs: n1 is the reference node immediately below zdes
C          b1 is the value of the n1's basis function at zdes
C          n2 is the reference node immediately above zdes
C          b2 is the value of the n2's basis function at zdes
C
C notes:   zdes<zref(1)  => n1=nn,b1=0.0,n2=1,b2=1.0 
C          zdes>zref(nn) => n1=nn,b1=1.0,n2=1,b2=0.0 
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           26 AUGUST 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      dimension zref(nn)
C
C START OF EXECUTABLE CODE
      do 10 k=1,nn 
         if(zdes.LT.zref(k))then
C
C if zdes<zref(1), zdes is below the reference data 
C                    => n1=nn,b1=0.0,n2=1,b2=1.0 
            n2=k
            n1=k-1
            if(n2.EQ.1)then
                n1=nn
                b1=0.0
                b2=1.0
                go to 20
             endif
             zdiff=zref(n2)-zref(n1)
             b1=(zref(n2)-zdes)/zdiff
             b2=(zdes-zref(n1))/zdiff  
             go to 20
         endif
 10   continue
C
C if zdes>zref(nn), zdes is above the reference data
C                     => n1=nn,b1=1.0,n2=1,b2=0.0
      b1=1.0
      n1=nn
      b2=0.0
      n2=1
 20   continue
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE BASIS2D(nndim,nedim,in,x,y,nn,ne,xval,yval,
     &nclosest,nelem,basis)
C-----------------------------------------------------------------------
C purpose: This subroutine determines the element on which the point
C            (xval,yval) resides and determines the value of the basis
C            functions at the point.  In the first pass, only elements 
C            containing the closest node to (xval,yval) are tested to 
C            see if (xval,yval) lies on them.  If this fails, all
C            elements are tested to see if (xval,yval) lies on them.
C
C
C restrictions: Applicable only for  2-D triangular linear elements
C
C calling sequence: CALL CLOSESTNODE(nndim,x,y,nn,xval,yval,nclosest)
C                   CALL POINTONEL(xlocal,ylocal,xval,yval,nflag)
C                   CALL PHI2D1(xlocal,ylocal,xval,yval,basis)
C
C inputs:  nn is the number of nodes in the mesh
C          x(nn),y(nn) 1-D arrays containing the are the x and y
C            coordinates of each nodes
C          ne is the number of elements in the mesh
C          in(3,ne) is the LABLIB Standard incidence list
C          xval,yval is the location of the point 
C          nedim is the size of the arrays in the calling routine
C
C outputs: basis is a 1-D array containing the value of the 3 basis
C            functions at the point xval,yval.
C          nelem is the element on which (xval,yval),resides
C          nclosest is the closest node to (xval,yval)
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           1992 APRIL 22 - Original Version
C           1997 MARCH 01 - Revised to call PHI2D1 instead of PHI2D to
C                           determine basis functions.  PHI2D1 is an
C                           improvement over PHI2D in that it less
C                           subject to round-off errors.
C-----------------------------------------------------------------------
C
C ARGUMENTS
      integer in(3,nedim)
      real x(nndim),y(nndim),basis(3)
C
C LOCAL VARIABLES
      dimension xlocal(3),ylocal(3)
C
C START OF EXECUTABLE CODE
C
C  Find the closest node to (xval,yval)
      CALL CLOSESTNODE(nndim,x,y,nn,xval,yval,nclosest)
C
C  Find if an element containing the closest node also contains the
C    point (xval,yval)
C
      do 10 i=1,ne
         n1=in(1,i)
         n2=in(2,i)
         n3=in(3,i)
         if(nclosest.EQ.n1.OR.nclosest.EQ.n2.OR.nclosest.EQ.n3)then
            xlocal(1)=x(n1)
            ylocal(1)=y(n1)
            xlocal(2)=x(n2)
            ylocal(2)=y(n2)
            xlocal(3)=x(n3)
            ylocal(3)=y(n3)
            CALL POINTONEL(xlocal,ylocal,xval,yval,nflag)
            if(nflag.EQ.1) then
               nelem=i
               CALL PHI2D1(xlocal,ylocal,xval,yval,basis)
               return
            endif
         endif
 10   continue
C
C  Find if any element contains the point (xval,yval)
C
      do 20 i=1,ne
         xlocal(1)=x(in(1,i))
         ylocal(1)=y(in(1,i))
         xlocal(2)=x(in(2,i))
         ylocal(2)=y(in(2,i))
         xlocal(3)=x(in(3,i))
         ylocal(3)=y(in(3,i))
         CALL POINTONEL(xlocal,ylocal,xval,yval,nflag)
         if(nflag.EQ.1) then
            nelem=i
            CALL PHI2D1(xlocal,ylocal,xval,yval,basis)
            return
         endif
 20   continue
      nelem=0
C
C END OF ROUTINE
C
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE CLOSESTNODE(nndim,x,y,nn,xval,yval,nclosest)
C-----------------------------------------------------------------------
C purpose: This subroutine finds the node closest to a point specified
C            by the coordinates (xval,yval)
C  
C restrictions:  all nodes must lie in a flat plane
C
C inputs:  x(nn) and y(nn) are 1-D arrays containing the x and y
C            coordinates of each node
C          nn is the number of nodes
C          xval,yval are the point coordinates
C
C outputs: nclosest is the node who's (x,y) coordinates are closest to
C            (xval,yval)
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 APRIL 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      dimension x(nndim),y(nndim)
C
C START OF EXECUTABLE CODE
C
C  Find node closest to (xval,yval)
      dclosest=SQRT((x(1)-xval)**2.0+(y(1)-yval)**2.0)
      nclosest=1
      do 25 j=2,nn
         dval=SQRT((x(j)-xval)**2.0+(y(j)-yval)**2.0)
         if(dval.LT.dclosest)then
            dclosest=dval
            nclosest=j
         endif
 25   continue
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
C***********************************************************************
C***********************************************************************
      SUBROUTINE FEMGEN(nndim,nedim,nseg,nnv,ord,abs,nele,incd)
C-----------------------------------------------------------------------
C purpose: This subroutine creates a 2-D Finite Element incidence list
C            for a 2-D grid of points (nseg+1)*nnv.
C
C restrictions: the coordinates of the nodes for which the
C               incidence list is being created must increase from
C               bottom to top and left to right, ie (for nseg=2,nnv=3):
C
C                             3 6 9
C                             2 5 8
C                             1 4 7
C
C index range: kk=1,nele
C
C inputs: Dimensioning parameters
C          nndim - parametered size of arrays indexed with i,m,n
C          nedim - parametered size of arrays indexed with kk
C         Vertical slice 2-D mesh data
C          nseg - number of horizontal sections
C          nnv - number of nodes in the vertical (constant)
C
C outputs: nele - number of elements = (nseg*(nnv-1))
C          incd - incidence list
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           MAY 4, 1993
C-----------------------------------------------------------------------
      integer incd(3,nedim)
      real ord(nndim),abs(nndim)
C
C START OF EXECUTABLE CODE
      kk=0
      do 30 i=1,nseg
         do 20 j=1,nnv-1
            n1=(i-1)*nnv+j
            n2=n1+nnv
            n3=n2+1
            n4=n1+1
            s21=(abs(n3)-abs(n1))**2.0+(ord(n3)-ord(n1))**2.0
            s22=(abs(n2)-abs(n4))**2.0+(ord(n4)-ord(n2))**2.0
            if(s21.LT.s22)then
               kk=kk+1
               incd(1,kk)=n1
               incd(2,kk)=n2
               incd(3,kk)=n3
               kk=kk+1
               incd(1,kk)=n1
               incd(2,kk)=n3
               incd(3,kk)=n4
            else
               kk=kk+1
               incd(1,kk)=n1
               incd(2,kk)=n2
               incd(3,kk)=n4
               kk=kk+1
               incd(1,kk)=n2
               incd(2,kk)=n3
               incd(3,kk)=n4
            endif
 20      continue
 30   continue
      nele=kk
      if(nele.GT.nedim)then
         write(*,*)' Increase nedim, the number of elements >',nedim
         stop
      endif
C
C END OF EXECUTABLE CODE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE PHI2D(xlocal,ylocal,xval,yval,phi)
C-----------------------------------------------------------------------
C purpose: This subroutine evaluates the value of the basis functions 
C            alive on a 2-D triangular linear element at a 
C            point (xval,yval) on a local element.
C
C restrictions: Applicable only for  2-D triangular linear element
C
C inputs:  xlocal(3) and ylocal(3) are 1-D arrays containing the x and y
C            coordinates of each local node on this element.
C            NOTE:  The node locations must be entered in a
C                     counterclockwise order (LABLIB standard)
C          xval,yval is the location of the point 
C
C outputs: phi is a 1-D array containing the value of the 3 basis
C            functions at the point xval,yval.
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 APRIL 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      dimension xlocal(3),ylocal(3),phi(3)
C
C START OF EXECUTABLE CODE
C
C Calculate the area of the element
      area=0.5*(xlocal(1)*(ylocal(2)-ylocal(3))
     &+xlocal(2)*(ylocal(3)-ylocal(1))+xlocal(3)*(ylocal(1)-ylocal(2)))
C
C Calculate the value of the basis functions at xval,yval
      do 20 i=1,3
         j=i+1
         k=i+2
         if(i.EQ.2)k=1
         if(i.EQ.3)then
            j=1
            k=2
         endif
         a=(xlocal(j)*ylocal(k)-xlocal(k)*ylocal(j))/(2.0*area)
         b=(ylocal(j)-ylocal(k))/(2.0*area)
         c=-(xlocal(j)-xlocal(k))/(2.0*area)
         phi(i)=a+b*xval+c*yval
 20   continue
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE PHI2D1(xl,yl,xvalu,yvalu,phi)
C-----------------------------------------------------------------------
C purpose: This subroutine evaluates the value of the linear basis
C            on a 2-D triangular linear element at a 
C            point (xvalu,yvalu) on a local element.
C
C restrictions: Applicable only for  2-D triangular linear element
C               Assumes that the fact that (xval,yval) lies on this 
C                 element has been determined a priori.
C               Attempts to eliminate round-off problems.
C               Minimum nodal area value is 0.0 => this subroutine
C                 can not be used to determine if the point in question
C                 is on an element
C
C inputs:  xl(3) and yl(3) are 1-D arrays containing the x and y
C            coordinates of each local node on this element.
C            NOTE:  The node locations must be entered in a
C                     counterclockwise order (LABLIB standard)
C          xvalu,yvalu is the location of the point 
C
C outputs: phi is a 1-D array containing the value of the 3 basis
C            functions at the point xval,yval.
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           1992 APRIL 22 - Original Version
C           1997 MARCH 01 - PHI2D1 - Revised version of PHI2D.
C                           Revised to reduce potential round-off errors
C                           which resulted in basis functions which
C                           were less than 0.0 and greater than 1.0 on
C                           some machines (this potential problem never
C                           revealed itself until early 1997).
C-----------------------------------------------------------------------
C
C ARGUMENTS
      dimension xl(3),yl(3),phi(3)
C
C START OF EXECUTABLE CODE
C
C Calculate twice the nodal areas
      A12=xvalu*(yl(2)-yl(3))+xl(2)*(yl(3)-yvalu)+xl(3)*(yvalu-yl(2))
      A22=xl(1)*(yvalu-yl(3))+xvalu*(yl(3)-yl(1))+xl(3)*(yl(1)-yvalu)
      A32=xl(1)*(yl(2)-yvalu)+xl(2)*(yvalu-yl(1))+xvalu*(yl(1)-yl(2))
C
C Do not allow for negative areas (which only occur due to round-off
C errors)
      A12=MAX(A12,0.0)
      A22=MAX(A22,0.0)
      A32=MAX(A32,0.0)
C
C Sum twice the nodal areas to get twice the total elemental area and 
C then evaluate basis functions
      AELE2=A12+A22+A32
      phi(1)=A12/AELE2      
      phi(2)=A22/AELE2     
      phi(3)=A32/AELE2      
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE POINTONEL(xlocal,ylocal,xval,yval,nflag)
C-----------------------------------------------------------------------
C purpose: This Subroutine determines if a point (xval,yval) is on a 
C            local 2-D triangular linear element
C    
C restrictions: Applicable only for  2-D triangular linear element
C
C inputs:  xlocal(3) and y(3) are 1-D arrays containing the x and y 
C            coordinates of each local node on this element.
C            NOTE:  The node locations must be entered in a
C                     counterclockwise order (LABLIB standard)
C          xval,yval is the location of the point 
C
C outputs: nflag is set equal to 1 if the point (xval,yval) is on the 
C            local element.
C          nflag is set equal to 0 if the point (xval,yval) is not on 
C            the local element.
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 APRIL 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      dimension xlocal(3),ylocal(3)
C
C LOCAL VARIABLES
      dimension vx(3),vy(3)
C
C  Calculate the x and y components of vectors pointing from (xval,yval)
C    to each node on the element
      do 10 i=1,3
         delx=xlocal(i)-xval
         dely=ylocal(i)-yval
         d=SQRT(delx**2.0+dely**2.0)
         theta=ATAN2(dely,delx)
         vx(i)=d*COS(theta)
         vy(i)=d*SIN(theta)
 10   continue
C
C  Determine if the point is on the element by calculating the
C    crossproducts of neighboring vectors in a direction
C    which yeild all positive numbers if x,y is on the element.
C    (ie: v1Xv2>0, v2Xv3>0, and v3Xv1>0 => x,y is on element)
      do 20 i=1,3
         j=i+1
         if(i.EQ.3)j=1
         crossprod=vx(i)*vy(j)-vy(i)*vx(j)
         if(crossprod.LT.0.0)then
            nflag=0
            go to 21
         endif
 20   continue
      nflag=1
 21   continue
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE POIVAL1D(nndim,data,b2,n2,b1,n1,atpoint)
C-----------------------------------------------------------------------
C purpose: This subroutine evaluates the value of the real nodal based 
C            quantity stored in the array data at a point specified by
C            the inputs.
C
C restrictions: Applicable only for  1-D linear interpolation
C
C inputs:  nndim is the dimensioning parameter for data
C          data is the 1-D nodal based array to be interpolated
C          b2 is the weight of n2's basis function at the desired point
C          n2 is the node directly above the desired point
C          b1 is the weight of n1's basis function at the desired point
C          n1 is the node directly below the desired point
C
C outputs: atpoint is the real value of data at the desired point
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 APRIL 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      dimension data(nndim)
C
C START OF EXECUTABLE ROUTINE
      atpoint=data(n1)*b1+data(n2)*b2
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE POIVAL1DC(nndim,data,b2,n2,b1,n1,atpoint)
C-----------------------------------------------------------------------
C purpose: This subroutine evaluates the value of the complex nodal
C            based quantity stored in the array data at a point
C            specified by the inputs.
C
C restrictions: Applicable only for  1-D linear interpolation
C
C inputs:  nndim is the dimensioning parameter for data
C          data is the 1-D nodal based array to be interpolated
C          b2 is the weight of n2's basis function at the desired point
C          n2 is the node directly above the desired point
C          b1 is the weight of n1's basis function at the desired point
C          n1 is the node directly below the desired point
C
C outputs: atpoint is the complex value of data at the desired point
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 APRIL 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      complex data(nndim)
      complex atpoint
C
C START OF EXECUTABLE ROUTINE
      atpoint=data(n1)*b1+data(n2)*b2
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE POIVAL2D(nndim,nedim,in,nelem,basis,data,atpoint)
C-----------------------------------------------------------------------
C purpose: This subroutine evaluates the value of the real nodal
C            based quantity stored in the array data, on element nelem. 
C
C restrictions: Applicable only for  2-D triangular linear element
C
C inputs:  nedim is the dimensioning parameter for the incidence list
C          nndim is the horizontal dimensioning parameter for data
C          in(3,nedim) is the element incidence list
C            NOTE:  The incidence list must be entered in a
C                     counterclockwise order (LABLIB standard)
C          nelem is the element number on which the desired point lies 
C          data is the quantity to be interpolated
C          basis(3) are the values of the basis functions at the point
C            where the nodal based quantity is desired
C
C outputs: atpoint is the real value of data at the desired point
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 APRIL 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      integer in(3,nedim)
      real data(nndim),basis(3)
C
C START OF EXECUTABLE ROUTINE
      atpoint=data(in(1,nelem))*basis(1)+data(in(2,nelem))*basis(2)
     &+data(in(3,nelem))*basis(3)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE POIVAL2DC(nndim,nedim,in,nelem,basis,data,atpoint)
C-----------------------------------------------------------------------
C purpose: This subroutine evaluates the value of the complex nodal
C            based quantity stored in the array data, on element nelem. 
C
C restrictions: Applicable only for  2-D triangular linear element
C
C inputs:  nedim is the dimensioning parameter for the incidence list
C          nndim is the horizontal dimensioning parameter for data
C          in(3,nedim) is the element incidence list
C            NOTE:  The incidence list must be entered in a
C                     counterclockwise order (LABLIB standard)
C          nelem is the element number on which the desired point lies 
C          data is the quantity to be interpolated
C          basis(3) are the values of the basis functions at the point
C            where the nodal based quantity is desired
C
C outputs: atpoint is the complex value of data at the desired point
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 APRIL 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      integer in(3,nedim)
      real basis(3)
      complex data(nndim)
      complex atpoint
C
C START OF EXECUTABLE ROUTINE
      atpoint=data(in(1,nelem))*basis(1)+data(in(2,nelem))*basis(2)
     &+data(in(3,nelem))*basis(3)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE POIVAL3D(nndim,nnvdim,nedim,in,jjj,nelem,basis,data,
     &atpoint)
C-----------------------------------------------------------------------
C purpose: This subroutine evaluates the value of the real nodal based 
C            quantity stored in the array data, on element nelem at 
C            vertical node jjj.
C
C restrictions: Applicable only 3-D data which has been computed using 
C            linear triangular elements in the horizontal and linear 
C            elements in the vertical (where the nodes line up in the 
C            vertical). 
C
C inputs:  in(3,nedim) is the element incidence list
C            NOTE:  The incidence list must be entered in a
C                     counterclockwise order (LABLIB standard)
C          nedim is the dimensioning parameter for the incidence list
C          nndim is the horizontal dimensioning parameter for data
C          nnvdim is the vertical dimensioning parameter for data
C          data is the quantity to be interpolated
C          nelem is the element number on which the desired point lies 
C          basis(3) are the values of the basis functions at the point
C            where the nodal based quantity is desired
C
C outputs: atpoint is the real value of data at the desired point
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 APRIL 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      integer in(3,nedim)     
      real data(nndim,nnvdim),basis(3)
C
C START OF EXECUTABLE ROUTINE
      atpoint=data(in(1,nelem),jjj)*basis(1)
     &+data(in(2,nelem),jjj)*basis(2)+data(in(3,nelem),jjj)*basis(3)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE POIVAL3DC(nndim,nnvdim,nedim,in,jjj,nelem,basis,data,
     &atpoint)
C-----------------------------------------------------------------------
C purpose: This subroutine evaluates the value of the real nodal based 
C            quantity stored in the array data, on element nelem at 
C            vertical node jjj.
C
C restrictions: Applicable only 3-D data which has been computed using 
C            linear triangular elements in the horizontal and linear 
C            elements in the vertical (where the nodes line up in the 
C            vertical). 
C
C inputs:  in(3,nedim) is the element incidence list
C            NOTE:  The incidence list must be entered in a
C                     counterclockwise order (LABLIB standard)
C          nedim is the dimensioning parameter for the incidence list
C          nndim is the horizontal dimensioning parameter for data
C          nnvdim is the vertical dimensioning parameter for data
C          data is the quantity to be interpolated
C          nelem is the element number on which the desired point lies 
C          basis(3) are the values of the basis functions at the point
C            where the nodal based quantity is desired
C
C outputs: atpoint is the real value of data at the desired point
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 APRIL 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      integer in(3,nedim)
      real basis(3)    
      complex data(nndim,nnvdim)
      complex atpoint
C
C START OF EXECUTABLE ROUTINE
      atpoint=data(in(1,nelem),jjj)*basis(1)
     &+data(in(2,nelem),jjj)*basis(2)+data(in(3,nelem),jjj)*basis(3)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE HALFBW(IN,NLOC,NE,NB)
C-----------------------------------------------------------------------
C  NB IS THE HALF-BANDWIDTH
C  NE IS THE NUMBER OF ELEMENTS
C  NOC IS THE FIRST DIMENSION OF IN
C  IN CONVENTION:IN(3,NEDIM)
C-----------------------------------------------------------------------
      DIMENSION IN(NLOC,*)      
      NB=0       
      DO L=1,NE       
         MI=IN(1,L)               
         MA=0       
         DO I=1,3        
            J=IN(I,L)           
            IF(J.LT.MI) MI=J             
            IF(J.GT.MA) MA=J             
         ENDDO 
         IDIFF=MA-MI         
         IF(IDIFF.GT.NB) NB=IDIFF     
      ENDDO 
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE REORDERINBE(nndim,nbedim,x,y,inbe,nbe)
C-----------------------------------------------------------------------
C purpose: This subroutine performs the following for the boundary
C          element incidence list:
C          1.check for errors 
C          2.reorder the boundary element incidence list so that it 
C             -begins at the node with a minimum value of x, 
C             -proceeds CCW around the outer boundary,
C             -then CW around each island
C          3.terminates execuation if any errors are found 
C
C restrictions:  Applicable only for Lablib Standard 2-D triangular mesh
C
C inputs:  nndim - dimension parameter for the number of nodes
C          nedim - dimension parameter for the number of elements
C          nbe - the number of boundary elements in the mesh
C          inbe - Lablib Standard incidence list for the boundary 
C                  elements
C
C outputs: Reordered incidence list (inbe)
C
C history: Written by Christopher E. Naimie
C          Dartmouth College
C          03 December 1998
C-----------------------------------------------------------------------
C
C ARGUMENTS
C
      real x(nndim),y(nndim)
      integer inbe(4,nbedim)
C
C START OF EXECUTABLE CODE
C
      nopen=0
      nclo=0
      ncflag=0
      istop=0
C
C Normalize all boundary elements such that the material to the left
C of an observer standing on inbe(1,i), looking toward inbe(2,i) is 0
C
      do i=1,nbe
         if(inbe(3,i).EQ.0)then
            if(inbe(4,i).EQ.0)then
               write(2,*)'INVALID BOUNDARY ELEMENT:',i
               write(2,*)'  (INBE(J,I),J=1,4)=',(INBE(J,I),J=1,4)
               istop=1
            endif
         elseif(inbe(4,i).EQ.0)then
            if(inbe(3,i).EQ.0)then
               write(2,*)'INVALID BOUNDARY ELEMENT:',i
               write(2,*)'  (INBE(J,I),J=1,4)=',(INBE(J,I),J=1,4)
               istop=1
            endif
            inbe1i=inbe(1,i)
            inbe(1,i)=inbe(2,i)
            inbe(2,i)=inbe1i
            inbe(4,i)=inbe(3,i)
            inbe(3,i)=0
         else
            write(2,*)'INVALID BOUNDARY ELEMENT:',i
            write(2,*)'  (INBE(J,I),J=1,4)=',(INBE(J,I),J=1,4)
            istop=1
         endif
      enddo
C
C Ensure that each boundary node occurs once and only once in the first
C two rows of inbe
C
      do i=1,nbe
         node=inbe(1,i)
         if(inbe(2,i).EQ.node)then
            write(2,*)'INVALID BOUNDARY ELEMENT:',i
            write(2,*)'  (INBE(J,I),J=1,4)=',(INBE(J,I),J=1,4)
            istop=1
         endif
         ncount=0
         do j=1,i-1
            if(inbe(2,j).EQ.node)ncount=ncount+1
         enddo
         do j=i+1,nbe
            if(inbe(2,j).EQ.node)ncount=ncount+1
         enddo
         if(ncount.NE.1)then
            write(2,*)'INVALID BOUNDARY ELEMENT LIST - NODE: ',node
            write(2,*)' APPEARS ',ncount,' TIMES IN 2ND ROW OF INBE'
            istop=1
         endif
         ncount=1
         do j=1,i-1
            if(inbe(1,j).EQ.node)ncount=ncount+1
         enddo
         do j=i+1,nbe
            if(inbe(1,j).EQ.node)ncount=ncount+1
         enddo
         if(ncount.NE.1)then
            write(2,*)'INVALID BOUNDARY ELEMENT LIST - NODE: ',node
            write(2,*)' APPEARS ',ncount,' TIMES IN 1ST ROW OF INBE'
            istop=1
         endif
      enddo
C
C Find the entry in the boundary element list with the minimum x
C (this must be part of the outer boundary)
C
      nmin=inbe(1,1)
      do i=2,nbe
         if(x(inbe(1,i)).LT.x(nmin))nmin=inbe(1,i)
      enddo
C
C Find the boundary element which has its head at nmin
C
      do i=1,nbe
         if(inbe(2,i).EQ.nmin)then
            nstart=inbe(1,i)
            nhead=inbe(2,i)
            ml=inbe(3,i)
            mr=inbe(4,i)
            inbe(1,i)=inbe(1,1)
            inbe(2,i)=inbe(2,1)
            inbe(3,i)=inbe(3,1)
            inbe(4,i)=inbe(4,1)
            inbe(1,1)=nstart
            inbe(2,1)=nhead
            inbe(3,1)=ml
            inbe(4,1)=mr
            go to 10
         endif
      enddo
C
C Start with first boundary element in list and close boundaries
C
 10   do 20 i=2,nbe
         if(ncflag.EQ.1)then
            ncflag=0
            go to 20
         endif
         do 18 j=i,nbe
            if(inbe(1,j).EQ.nhead)then
               n1=inbe(1,i)
               n2=inbe(2,i)
               ml=inbe(3,i)
               mr=inbe(4,i)
               inbe(1,i)=inbe(1,j)
               inbe(2,i)=inbe(2,j)
               inbe(3,i)=inbe(3,j)
               inbe(4,i)=inbe(4,j)
               inbe(1,j)=n1
               inbe(2,j)=n2
               inbe(3,j)=ml
               inbe(4,j)=mr
               nhead=inbe(2,i)
               go to 19
            endif
 18      continue
         if(i.LT.(nbe))then
            nopen=nopen+1
            nstart=inbe(1,i)
            nhead=inbe(2,i)
            istop=1
         endif
         go to 20           
 19      if(inbe(2,i).EQ.nstart.AND.i.LT.nbe)then
            nclo=nclo+1
            ncflag=1
            nstart=inbe(1,i+1)
            nhead=inbe(2,i+1)
         endif
         if(inbe(2,i).EQ.nstart.AND.i.EQ.nbe)then
            nclo=nclo+1
            go to 21
         endif
 20   continue
      nopen=nopen+1
      istop=1
 21   continue
C
C Report statistical info and stop if errors were found
C
      if(istop.EQ.1)then
         WRITE(2,*)'EXECUTION TERMINATED IN SUBROUTINE REORDERINBE DUE',
     &             ' TO FATAL FLAW IN INPUT BOUNDARY ELEMENT FILE:'
         WRITE(2,*)NCLO,' CLOSED BOUNDARIES WERE FOUND.'
         WRITE(2,*)NOPEN,' OPEN BOUNDARIES WERE FOUND.'
         STOP
      endif
C
C END OF ROUTINE
C
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE VERTSUM(F,FSUM,NN,NEV,NNDIM)
C-----------------------------------------------------------------------
C COMPUTES THE VERTICAL SUM OF F, RETURNS IT IN FSUM.
C DOES THIS FOR ALL HORIZONTAL NODES
C SUMMATION IS PERFORMED FROM ELEMENT 1 TO ELEMENT NEV
C NNDIM IS THE FIRST PHYSICAL DIMENSION OF F IN MAIN.
C-----------------------------------------------------------------------
      REAL F(NNDIM,*), FSUM(*)
      DO I=1,NN
         FS=0.0
         DO J=1,NEV
            FS=FS+F(I,J)
         ENDDO
         FSUM(I)=FS
      ENDDO
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE VERTINTI(F,FINT,Z,NNV)
      REAL F(*),Z(*)
C-----------------------------------------------------------------------
C COMPUTES THE VERTICAL INTEGRAL OF F, RETURNS IT IN FINT.
C DOES NOT REQUIRE UNIFORM MESH
C INTEGRATION IS PERFORMED FROM NODE 1 TO NODE NNV
C-----------------------------------------------------------------------
      FINT=0.0
      DO J=2,NNV
         FINT=FINT+0.5*(F(J)+F(J-1))*(Z(J)-Z(J-1))
      ENDDO
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE VERTAVG(F,FAVG,Z,NN,NNV,NNDIM)
      REAL F(NNDIM,*),FAVG(*),Z(NNDIM,*)
C-----------------------------------------------------------------------
C COMPUTES THE VERTICAL AVERAGE OF F, RETURNS IT IN FAVG.
C DOES THIS FOR ALL HORIZONTAL NODES
C DOES NOT REQUIRE UNIFORM MESH
C INTEGRATION IS PERFORMED FROM NODE 1 TO NODE NNV
C NNDIM IS THE FIRST PHYSICAL DIMENSION OF F AND Z IN MAIN.
C-----------------------------------------------------------------------
      DO I=1,NN
         FINT=0.0
         DO J=2,NNV
            FINT=FINT+0.5*(F(I,J)+F(I,J-1))*(Z(I,J)-Z(I,J-1))
         ENDDO
         FAVG(I)=FINT/(Z(I,NNV)-Z(I,1))
      ENDDO
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE VERTAVGC(F,FAVG,Z,NN,NNV,NNDIM)
      COMPLEX F(NNDIM,*),FAVG(*)
      COMPLEX FINT
      REAL Z(NNDIM,*)
C-----------------------------------------------------------------------
C COMPUTES THE VERTICAL AVERAGE OF F, RETURNS IT IN FAVG.
C DOES THIS FOR ALL HORIZONTAL NODES
C DOES NOT REQUIRE UNIFORM MESH
C INTEGRATION IS PERFORMED FROM NODE 1 TO NODE NNV
C NNDIM IS THE FIRST PHYSICAL DIMENSION OF F AND Z IN MAIN.
C
C THIS ROUTINE IS THE COMPLEX VERSION OF VERTAVG
C-----------------------------------------------------------------------
      DO I=1,NN
         FINT=0.0
         DO J=2,NNV
            FINT=FINT+0.5*(F(I,J)+F(I,J-1))*(Z(I,J)-Z(I,J-1))
         ENDDO
         FAVG(I)=FINT/(Z(I,NNV)-Z(I,1))
      ENDDO
      RETURN
      END
C***********************************************************************
C***********************************************************************
C END OF FEMPAK
C END OF FEMPAK
C***********************************************************************
C***********************************************************************
C***********************************************************************
C***********************************************************************
C BEGINNING OF GOMPAK
C BEGINNING OF GOMPAK
C***********************************************************************
C***********************************************************************
C
C GOMPAK
C
C***********************************************************************
C***********************************************************************
      SUBROUTINE CSTRING(string,istart,iend)
C-----------------------------------------------------------------------
C purpose: This subroutine finds the first nonblank space (istart) in a 
C            arbitrary character string and the first subsequent blank
C            space (iend).  The range of string between istart and iend
C            can then be separated from the rest of string by specifying
C            string(istart:iend)
C
C
C inputs:  string - a character string of length .LE. 72
C
C outputs: istart - first nonblank character in string
C          iend   - first blank character in string after istart
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           12 JUNE 1992
C-----------------------------------------------------------------------
C
C ARGUMENTS
      character*72 string
C
C START OF EXECUTABLE CODE
C
C find beginning of string
      do 10 i=1,72
         istart=i
	 if(string(i:i).NE.' ')go to 11
 10   continue
C
C find end of string
 11   do 20 i=istart,72
         iend=i-1
	 if(string(i:i).EQ.' ')go to 21
 20   continue
C
C END OF ROUTINE
 21   return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE CROPSTRING(string,istart,ibeg,iend)
C-----------------------------------------------------------------------
C purpose: This subroutine finds 3 pointers for for a character string
C
C inputs:  string - a character string of length .LE. 72
C
C outputs: istart - first nonblank character in string
C          ibeg   - location of character in string which follows the 
C                   last "/" entry before iend
C          iend   - first blank character in string after istart
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           08 DEC 1998
C-----------------------------------------------------------------------
C
C ARGUMENTS
      character*72 string
C
C START OF EXECUTABLE CODE
C
C find beginning of string
      do 10 i=1,72
         istart=i
	 if(string(i:i).NE.' ')go to 11
 10   continue
C
C find end of string
 11   do 20 i=istart,72
         iend=i-1
	 if(string(i:i).EQ.' ')go to 21
 20   continue
C 
C find the last / before end of string
 21   do 30 i=iend,istart,-1
         ibeg=i+1
         if(string(i:i).EQ.'/')go to 31
 30   continue
      ibeg=istart
C
C END OF ROUTINE
 31   return
      end
C***********************************************************************
C***********************************************************************
        SUBROUTINE ELLIPSE (U,V,amaj,amin,ainc,g,apl,amn,gpl,gmin)
C-----------------------------------------------------------------------
C
C COMPUTES TIDAL ELLIPSE PARAMETERS FROM COMPLEX VELOCITIES U,V.
C
        COMPLEX U,V
        PI=ACOS(-1.0)
        FAC=PI/180.
C
C TAKEN FROM TEMP.FOR AT IOS
C
        CX=REAL(U)
        SX=-AIMAG(U)
        CY=REAL(V)
        SY=-AIMAG(V)
	cxpsy=0.5*(cx+sy)
	cymsx=0.5*(cy-sx)
	cxmsy=0.5*(cx-sy)
	cypsx=0.5*(cy+sx)
	apl=sqrt(cxpsy**2+cymsx**2)
	amn=sqrt(cxmsy**2+cypsx**2)
	if(apl.gt.1.e-5) then
	epl=atan2(cymsx,cxpsy)/fac
	else
	epl=0.
	end if
	if(amn.gt.1.e-5) then
	emin=atan2(cypsx,cxmsy)/fac
	else
	emin=0.
	end if
	amaj=apl+amn
	amin=apl-amn
	gpl=-epl
	gmin=emin
	if(gmin-gpl.lt.0.) gmin=gmin+360.
	g=0.5*(gpl+gmin)
	ainc=0.5*(gmin-gpl)
	if(gmin.lt.0.) gmin=gmin+360.
	if(gmin.gt.360.) gmin=gmin-360.
	if(gpl.lt.0.) gpl=gpl+360.
        RETURN
        END
C
C***********************************************************************
C***********************************************************************
      SUBROUTINE HSUBMESH(nndim,nedim,nnvdim,nn,nnv,ne,x,y,z,in,
     &depth,xmin,xmax,ymin,ymax,nn1,ne1,x1,y1,in1,map)
C-----------------------------------------------------------------------
C purpose: This subroutine invokes a filtering mechanism which extracts
C           the portion of an existing mesh which lies within a
C           horizontal window at a given depth.
C
C restrictions: QUODDY style 3-D mesh
C               currently uses horizontal mesh filter HSUBMESH
C               requires the include file QUODDY.DIM
C
C index range: i=1,nn, ii=1,nn1, j=1,nnv, k=1,ne, kk=1,ne1
C
C inputs from calling routine:
C         3-D mesh input data
C          nndim - horizontal node number parameter
C          nedim - horizontal element number parameter
C          nnvdim - vertical node number parameter
C          nn - number of horizontal nodes
C          nnv - number of nodes in the vertical
C          ne - number of horizontal elements
C          x(i),y(i) - cartesian horizontal nodal coordinates
C          z(i,j) - 3-D vertical nodal coordinates
C          in(3,k) - incidence list
C         Horizontal section data
C          (xmin,xmax) is the range of x
C          (ymin,ymax) is the range of y
C          depth - depth of horizontal sections
C
C outputs:Horizontal 2-D mesh data
C          nn1 - number of horizontal nodes
C          ne1 - number of horizontal elements
C          x1(ii),y1(ii) - cartesian horizontal nodal coordinates
C          in(3,kk) - incidence list
C          map(i) - coincidence list which indicates which original
C                    mesh nodes are part of filtered mesh (nonzero
C                    entries).
C
C history: Written by Christopher E. Naimie
C          Dartmouth College
C          JUN 24, 1995
C-----------------------------------------------------------------------
C
C Global Arrays
      real x(nndim),y(nndim),z(nndim,nnvdim)
      integer in(3,nedim)
      real x1(nndim),y1(nndim)
      integer in1(3,nedim)
      integer map(nndim)
C
C  Flag nodes within the window that have depths exceeding desired depth
      do 10 i=1,nndim
         map(i)=0
 10   continue
      nn1=0
      do 20 i=1,nn
          if(x(i).LT.xmin.OR.x(i).GT.xmax)go to 20
          if(y(i).LT.ymin.OR.y(i).GT.ymax)go to 20
          if(-depth.LT.z(i,1).OR.-depth.GT.z(i,nnv))go to 20
          nn1=nn1+1
          map(i)=nn1
          x1(nn1)=x(i)
          y1(nn1)=y(i)
 20   continue
C
C  Create new mesh arrays for elements with all nodes within the window
      ne1=0
      do 40 l=1,nedim
         n1=in(1,l)
         n2=in(2,l)
         n3=in(3,l)
         if(map(n1).NE.0.AND.map(n2).NE.0.AND.map(n3).NE.0)then
            ne1=ne1+1
            do 30 i=1,3
               in1(i,ne1)=map(in(i,l))
 30         continue
         endif
 40   continue
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADIN(filename,nedim,in,ne)
C-----------------------------------------------------------------------
C purpose: This routine loads LABLIB Standard  element files
C
C restrictions: Applicable only for 2-D triangular linear element 
C                 LABLIB Standard files
C
C inputs:  nedim is the parameter for dimensioning the incidence list
C
C outputs: ne is the number of elements in the mesh
C          in(3,ne) is the LABLIB Standard incidence list
C 
C file format: LABLIB Standard
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 FEBRUARY 1994
C           Revised: 25 FEBRUARY 1995
C-----------------------------------------------------------------------
C
C ARGUMENTS
      integer in(3,nedim)
      character*72 filename
C
C READ ELEMENT DATA FROM FILE
      open(14,file=filename,status='old')
      do 10 i=1,nedim
        read(14,*,end=11)ne,in(1,i),in(2,i),in(3,i)
 10   continue
         write(*,*)' Potential error reading .ele file =>',
     &             ' increase nedim such that it exceeds the number of',
     &             ' elements by at least 1 and recompile.'
         stop
 11   continue
      write(*,*)ne, 'elements read from ',filename
      close(14)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADLST(nndim,nlevels,nn,nlev,filename,zl,sigtl)
C-----------------------------------------------------------------------
C purpose: This routine loads a level surface sigmat .lst file
C
C index range: i=1,nn, l=1,nlev
C
C inputs:  nndim - parametered size of arrays indexed with i
C          nlevels - parametered size of arrays indexed with l
C          nn - number of horizontal nodes
C          filename - name of .lst file
C
C outputs: nlev - number of level surfaces in .lst file
C          zl(l) - z coordinate of level mesh nodes
C          sigtl(i,l) - sigmat at level mesh locations
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           JANUARY 1, 1993
C           Revised: 25 APRIL 1994
C-----------------------------------------------------------------------
C
C Global arrays
      real zl(nlevels), sigtl(nndim,nlevels)
C
C Local assignments
      character*72 filename,header
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
      read(63,*)nlev
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADLST:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADLST:'
         write(*,*)'  nlev exceeds nlevels => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read zl
      read(63,*)(zl(l),l=1,nlev)
C
C Read sigmat data
      do 20 i=1,nndim
         do 10 l=1,nlev
            read(63,*,end=21)sigtl(i,l)
            ll=l
 10      continue
         ii=i
 20   continue
 21   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .lst file and nn in SUBROUTINE LOADLST.'
         STOP
      else
         write(*,*)ii,'x',ll,' real 3-D sigmat values loaded from ',
     &filename
      endif
C
C Format statements
 101  format(a)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADMESH(nndim,nedim,nfile,efile,x,y,in,nn,ne)
C-----------------------------------------------------------------------
C purpose: This routine loads LABLIB Standard node and element files for
C            a 2-D triangular finite element mesh
C
C index range: i=1,nn, k=1,ne
C
C inputs:  nndim - parameter for dimensioning the nodal coordinates
C          nedim - parameter for dimensioning the incidence list
C          nfile - name of the LABLIB Standard node file
C          efile - name of the LABLIB Standard element file
C
C outputs: nn - number of nodes in the mesh
C          x(i),y(i) - nodal x and y coordinates for node i
C          ne - number of elements in the mesh
C          in(3,k) - LABLIB Standard incidence list for element j
C 
C file format: LABLIB Standard 2-D triangular linear element mesh
C              See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           25 AUGUST 1992
C           Revised: 25 APRIL 1994
C           Revised: 25 FEBRUARY 1995
C-----------------------------------------------------------------------
C
C ARGUMENTS
      integer in(3,nedim)     
      dimension x(nndim),y(nndim)
      character*72 nfile,efile
C
C START OF EXECUTABLE CODE
C
C  Read node coordinates nfile
      open(81,file=nfile,status='old')
      do 5 i=1,nndim
        read(81,*,end=6)nn,x(i),y(i)
 5    continue
         write(*,*)' Potential error reading .nod file =>',
     &             ' increase nndim such that it exceeds the number of',
     &             ' nodes by at least 1 and recompile.'
         stop
 6    continue
      write(*,*)nn, 'nodes read from ',nfile
      close(81)
C
C Read element data from file
      open(82,file=efile,status='old')
      do 10 i=1,nedim
        read(82,*,end=11)ne,in(1,ne),in(2,ne),in(3,ne)
 10   continue
         write(*,*)' Potential error reading .ele file =>',
     &             ' increase nedim such that it exceeds the number of',
     &             ' elements by at least 1 and recompile.'
         stop
 11   continue
      write(*,*)ne, 'elements read from ',efile
      close(82)
C
C END OF ROUTINE
C
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADMESHGOM(nndim,nedim,pathmesh,x,y,in,bathy,nn,ne)
C-----------------------------------------------------------------------
C purpose: This routine loads LABLIB Standard node and element files for
C            a 2-D triangular finite element mesh
C
C index range: i=1,nn, k=1,ne
C
C inputs:  nndim - parameter for dimensioning the nodal coordinates
C          nedim - parameter for dimensioning the incidence list
C          pathmesh - the leading part of the path for the .nod, .ele,
C                       and .bat files.
C                  i.e.: g2s.nod, g2s.ele, and g2s.bat => pathmesh=g2s
C
C outputs: nn - number of nodes in the mesh
C          x(i),y(i) - nodal x and y coordinates for node i
C          bathy(i) - bathymetric depth for node i
C          ne - number of elements in the mesh
C          in(3,k) - LABLIB Standard incidence list for element j
C 
C file format: LABLIB Standard 2-D triangular linear element mesh
C              See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 APRIL 1992
C           Revised: 25 APRIL 1994
C           Revised: 25 FEBRUARY 1995
C-----------------------------------------------------------------------
C
C ARGUMENTS
      integer in(3,nedim)     
      dimension x(nndim),y(nndim),bathy(nndim)
      character*72 pathmesh
C
C START OF EXECUTABLE CODE
C
C Use cstring to find limits of pathmesh
      CALL CSTRING(pathmesh,lms,lme)
C
C open .nod, .ele, and .bat data files
      open(12,file=pathmesh(lms:lme)//'.nod',status='old')
      open(13,file=pathmesh(lms:lme)//'.bat',status='old')
      open(14,file=pathmesh(lms:lme)//'.ele',status='old')
C
C  Read node coordinates and the scalar value at each node from files
      do 5 i=1,nndim
        read(12,*,end=6)nn,x(i),y(i)
        read(13,*)nn,bathy(i)
 5    continue
         write(*,*)' Potential error reading .nod file =>',
     &             ' increase nndim such that it exceeds the number of',
     &             ' nodes by at least 1 and recompile.'
         stop
 6    continue
      write(*,*)nn, 'nodal coordinates read from ',
     &pathmesh(lms:lme),'.nod'
      write(*,*)nn, 'nodal bathymetries read from ',
     &pathmesh(lms:lme),'.bat'
      close(12)
      close(13)
C
C Read element data from file
      do 10 i=1,nedim
        read(14,*,end=11)ne,in(1,i),in(2,i),in(3,i)
 10   continue
         write(*,*)' Potential error reading .ele file =>',
     &             ' increase nedim such that it exceeds the number of',
     &             ' elements by at least 1 and recompile.'
         stop
 11   continue
      write(*,*)ne, 'elements read from ',pathmesh(lms:lme),'.ele'
      close(14)
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
C
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADMESHGOMLL(nndim,nedim,pathmesh,
     &xlon,ylat,in,bathy,nn,ne)
C-----------------------------------------------------------------------
C purpose: This routine loads LABLIB Standard node and element files for
C            a 2-D triangular finite element mesh, where the node file
C            contains nodal positions in (lon,lat) coordinates
C
C index range: i=1,nn, k=1,ne
C
C inputs:  nndim - parameter for dimensioning the nodal coordinates
C          nedim - parameter for dimensioning the incidence list
C          pathmesh - the leading part of the path for the .nod, .ele,
C                       and .bat files.
C                  i.e.: g2sll.nod, g2s.ele, and g2s.bat => pathmesh=g2s
C
C outputs: nn - number of nodes in the mesh
C          xlon(i),ylat(i) - nodal x and y coordinates for node i
C          bathy(i) - bathymetric depth for node i
C          ne - number of elements in the mesh
C          in(3,k) - LABLIB Standard incidence list for element j
C 
C file format: LABLIB Standard 2-D triangular linear element mesh
C              See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           22 APRIL 1992
C           Revised: 25 APRIL 1994
C           Revised: 25 FEBRUARY 1995
C-----------------------------------------------------------------------
C
C ARGUMENTS
      integer in(3,nedim)     
      dimension xlon(nndim),ylat(nndim),bathy(nndim)
      character*72 pathmesh
C
C START OF EXECUTABLE CODE
C
C Use cstring to find limits of pathmesh
      CALL CSTRING(pathmesh,lms,lme)
C
C open .nod, .ele, and .bat data files
      open(12,file=pathmesh(lms:lme)//'ll.nod',status='old')
      open(13,file=pathmesh(lms:lme)//'.bat',status='old')
      open(14,file=pathmesh(lms:lme)//'.ele',status='old')
C
C  Read node coordinates and the scalar value at each node from files
      do 5 i=1,nndim
        read(12,*,end=6)nn,xlon(i),ylat(i)
        read(13,*)nn,bathy(i)
 5    continue
         write(*,*)' Potential error reading .nod file =>',
     &             ' increase nndim such that it exceeds the number of',
     &             ' nodes by at least 1 and recompile.'
         stop
 6    continue
      write(*,*)nn, 'nodal coordinates read from ',
     &pathmesh(lms:lme),'.nod'
      write(*,*)nn, 'nodal bathymetries read from ',
     &pathmesh(lms:lme),'.bat'
      close(12)
      close(13)
C
C Read element data from file
      do 10 i=1,nedim
        read(14,*,end=11)ne,in(1,i),in(2,i),in(3,i)
 10   continue
         write(*,*)' Potential error reading .ele file =>',
     &             ' increase nedim such that it exceeds the number of',
     &             ' elements by at least 1 and recompile.'
         stop
 11   continue
      write(*,*)ne, 'elements read from ',pathmesh(lms:lme),'.ele'
      close(14)
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
C
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADNOD(nfile,nndim,x,y,nn)
C-----------------------------------------------------------------------
C purpose: This routine loads LABLIB Standard node file for
C            a 2-D triangular finite element mesh
C
C index range: i=1,nn, k=1,ne
C
C inputs:  nndim - parameter for dimensioning the nodal coordinates
C          nfile - name of the LABLIB Standard node file
C
C outputs: nn - number of nodes in the mesh
C          x(i),y(i) - nodal x and y coordinates for node i
C 
C file format: LABLIB Standard 2-D triangular linear element mesh
C              See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           25 FEBRUARY 1995
C-----------------------------------------------------------------------
C
C ARGUMENTS
      dimension x(nndim),y(nndim)
      character*72 nfile
C
C START OF EXECUTABLE CODE
C
C  Read node coordinates nfile
      open(81,file=nfile,status='old')
      do 5 i=1,nndim
        read(81,*,end=6)nn,x(i),y(i)
 5    continue
         write(*,*)' Potential error reading .nod file =>',
     &             ' increase nndim such that it exceeds the number of',
     &             ' nodes by at least 1 and recompile.'
         stop
 6    continue
      write(*,*)nn, 'nodes read from ',nfile
      close(81)
C
C END OF ROUTINE
C
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADREVEL(nndim,nnvdim,nn,nnv,filename,zval,u,v,w)
C-----------------------------------------------------------------------
C purpose: This routine loads the real parts of a .vel file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          nn - number of horizontal nodes for which data should 
C            exist
C          nnv - number of vertical nodes for which data should 
C            exist  =>  data should exist for nn*nnv nodes
C          filename - name of file to be read
C
C outputs: zval(i,j) - z coordinate at horizontal node i
C            and vertical node j           
C          u(i,j) - x-component of the vector at horizontal 
C            node i and vertical node j
C          v(i,j) - y-component of the vector at horizontal 
C            node i and vertical node j
C          w(i,j) - z-component of the vector at horizontal 
C            node i and vertical node j
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           30 JULY 1992
C           Revised: 25 APRIL 1994
C-----------------------------------------------------------------------
C
C ARGUMENTS
      real zval(nndim,nnvdim)
      real u(nndim,nnvdim),v(nndim,nnvdim),w(nndim,nnvdim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
      read(63,*)nnv
      read(63,101)header
      read(63,*)freq
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADREVEL:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADREVEL:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      do 20 i=1,nndim
         do 10 j=1,nnv
            read(63,*,end=21)no,zval(i,j),u(i,j),up,v(i,j),vp,w(i,j),wp
            u(i,j)=COS(up)*u(i,j)
            v(i,j)=COS(vp)*v(i,j)
            w(i,j)=COS(wp)*w(i,j)
            jj=j
 10      continue
         ii=i
 20   continue
 21   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .vel file and nn in SUBROUTINE LOADREVEL.'
         STOP
      else
         write(*,*)ii,'x',jj,' real 3-D vector values loaded from ',
     &filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADS2C(nndim,nn,filename,scval,freq)
C-----------------------------------------------------------------------
C purpose: This routine loads a .s2c file
C
C index range: i=1,nn
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nn - number of nodes for which data should exist
C          filename - name of file to be read
C
C outputs: scval(nnn) - complex scalar value at node nnn
C          freq - frequency in radians/sec
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           30 JULY 1992
C           Revised: 25 APRIL 1994
C-----------------------------------------------------------------------
C
C ARGUMENTS
      complex scval(nndim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
      read(63,*)freq
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADS2C:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      fac=2.0*ATAN2(1.0,0.0)/180.0
      do 10 i=1,nndim
         read(63,*,end=11)node,amp,phase
         scval(i)=CMPLX(amp*COS(-phase*fac),amp*SIN(-phase*fac))
         ii=i
 10   continue
 11   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .s2c file and nn in SUBROUTINE LOADS2C.'
         STOP
      else
         write(*,*)ii,' complex 2-D scalar values loaded from ',filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADS2R(nndim,nn,filename,scval)
C-----------------------------------------------------------------------
C purpose: This routine loads a .s2r file
C
C index range: i=1,nn
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nn - number of nodes for which data should exist
C          filename - name of file to be read
C
C outputs: scval(i) - real scalar value at node i
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           30 JULY 1992
C           Revised: 25 APRIL 1994
C-----------------------------------------------------------------------
C
C ARGUMENTS
      real scval(nndim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADS2R:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      do 10 i=1,nndim
         read(63,*,end=11)node,scval(node)
         ii=i
 10   continue
 11   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .s2r file and nn in SUBROUTINE LOADS2R.'
         STOP
      else
         write(*,*)ii,' real 2-D scalar values loaded from ',filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADBAT(nndim,nn,filename,batval)
C-----------------------------------------------------------------------
C purpose: This routine loads a .bat file
C
C index range: i=1,nn
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nn - number of nodes for which data should exist
C          filename - name of file to be read
C
C outputs: scval(i) - real scalar value at node i
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           1992 JULY 30  - LOADS2R
C           1994 APRIL 25 - LOADS2R Revision
C           1997 FEB 08 - LOADBAT
C-----------------------------------------------------------------------
C
C ARGUMENTS
      real batval(nndim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADBAT:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      do 10 i=1,nndim
         read(63,*,end=11)node,batval(node)
         ii=i
 10   continue
 11   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .bat file and nn in SUBROUTINE LOADBAT.'
         STOP
      else
         write(*,*)ii,' real 2-D scalar values loaded from ',filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADS3C(nndim,nnvdim,nn,nnv,filename,zval,scval,freq)
C-----------------------------------------------------------------------
C purpose: This routine loads a .s3c 3-D file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          nn - number of horizontal nodes for which data should 
C            exist
C          filename - name of file to be read
C
C outputs: scval(i,j) - complex scalar value at horizontal
C            node i and vertical node j
C          zval(i,j) - z coordinate at horizontal node i
C            and vertical node j           
C          nnv - number of vertical nodes 
C          freq - frequency in radians/sec
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           19 MAY 1995
C-----------------------------------------------------------------------
C
C ARGUMENTS
      real zval(nndim,nnvdim)
      complex scval(nndim,nnvdim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
      read(63,*)nnv
      read(63,*)freq
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADS3C:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADS3C:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      fac=2.0*ATAN2(1.0,0.0)/180.0
      do 20 i=1,nndim
         do 10 j=1,nnv
            read(63,*,end=21)node,zval(i,j),amp,phase
            scval(i,j)=CMPLX(amp*COS(-phase*fac),amp*SIN(-phase*fac))
            jj=j
 10      continue
         ii=i
 20   continue
 21   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .s3c file and nn in SUBROUTINE LOADS3C.'
         STOP
      else
         write(*,*)ii,'x',jj,' complex 3-D scalar values loaded from ',
     &filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADS3R(nndim,nnvdim,nn,nnv,filename,zval,scval)
C-----------------------------------------------------------------------
C purpose: This routine loads a scalar 3-D file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          nn - number of horizontal nodes for which data should 
C            exist
C          filename - name of file to be read
C
C outputs: scval(i,j) - real scalar value at horizontal
C            node i and vertical node j
C          zval(i,j) - z coordinate at horizontal node i
C            and vertical node j           
C          nnv - number of vertical nodes 
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           30 JULY 1992
C           Revised: 25 APRIL 1994
C-----------------------------------------------------------------------
C
C ARGUMENTS
      real zval(nndim,nnvdim), scval(nndim,nnvdim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
      read(63,*)nnv
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADS3R:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADS3R:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      do 20 i=1,nndim
         do 10 j=1,nnv
            read(63,*,end=21)node,zval(i,j),scval(i,j)
            jj=j
 10      continue
         ii=i
 20   continue
 21   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .s3r file and nn in SUBROUTINE LOADS3R.'
         STOP
      else
         write(*,*)ii,'x',jj,' real 3-D scalar values loaded from ',
     &filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADV2C(nndim,nn,filename,u,v,freq)
C-----------------------------------------------------------------------
C purpose: This routine loads a .v2c file
C
C index range: i=1,nn
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nn - number of nodes for which data should exist
C          filename - name of file to be read
C
C outputs: u(i) - x-component of the complex vector at node i 
C          v(i) - y-component of the complex vector at node i
C          freq - frequency in radians/sec
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           30 JULY 1992
C           Revised: 25 APRIL 1994
C-----------------------------------------------------------------------
C
C ARGUMENTS
      complex u(nndim),v(nndim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
      read(63,*)freq
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADV2C:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      fac=2.0*ATAN2(1.0,0.0)/180.0
      do 10 i=1,nndim
         read(63,*,end=11)node,uamp,upha,vamp,vpha
         u(i)=CMPLX(uamp*COS(-upha*fac),uamp*SIN(-upha*fac))
         v(i)=CMPLX(vamp*COS(-vpha*fac),vamp*SIN(-vpha*fac))
         ii=i
 10   continue
 11   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .v2c file and nn in SUBROUTINE LOADV2C.'
         STOP
      else
         write(*,*)ii,' complex 2-D vector values loaded from ',filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADV2R(nndim,nn,filename,u,v)
C-----------------------------------------------------------------------
C purpose: This routine loads a .v2r file
C
C index range: i=1,nn
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nn - number of nodes for which data should exist
C
C outputs: u(i) - x-component of the real vector at node i
C          v(i) - y-component of the real vector at node i
C          filename - name of file to be read
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           30 JULY 1992
C           Revised: 25 APRIL 1994
C-----------------------------------------------------------------------
C
C ARGUMENTS
      real u(nndim),v(nndim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADV2R:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      do 10 i=1,nndim
         read(63,*,end=11)node,u(node),v(node)
         ii=i
 10   continue
 11   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .v2r file and nn in SUBROUTINE LOADV2R.'
         STOP
      else
         write(*,*)ii,' real 2-D vector values loaded from ',filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADV3R(nndim,nnvdim,nn,nnv,filename,zval,u,v,w)
C-----------------------------------------------------------------------
C purpose: This routine loads a .v3r file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          nn - number of horizontal nodes for which data should 
C            exist
C          nnv - number of vertical nodes for which data should 
C            exist  =>  data should exist for nn*nnv nodes
C          filename - name of file to be read
C
C outputs: zval(i,j) - z coordinate at horizontal node i
C            and vertical node j           
C          u(i,j) - x-component of the vector at horizontal 
C            node i and vertical node j
C          v(i,j) - y-component of the vector at horizontal 
C            node i and vertical node j
C          w(i,j) - z-component of the vector at horizontal 
C            node i and vertical node j
C          freq - frequency in radians/sec
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           30 JULY 1992
C           Revised: 25 APRIL 1994
C-----------------------------------------------------------------------
C
C ARGUMENTS
      real zval(nndim,nnvdim)
      real u(nndim,nnvdim),v(nndim,nnvdim),w(nndim,nnvdim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
      read(63,*)nnv
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SURBROUTINE LOADV3R:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADV3R:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      do 20 i=1,nndim
         do 10 j=1,nnv
            read(63,*,end=21)node,zval(i,j),u(i,j),v(i,j),w(i,j)
            jj=j
 10      continue
         ii=i
 20   continue
 21   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .v3r file and nn in SUBROUTINE LOADV3R.'
         STOP
      else
         write(*,*)ii,'x',jj,' real 3-D vector values loaded from ',
     &filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADVEL(nndim,nnvdim,nn,nnv,filename,zval,u,v,w,freq)
C-----------------------------------------------------------------------
C purpose: This routine loads a .vel file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          nn - number of horizontal nodes for which data should 
C            exist
C          nnv - number of vertical nodes for which data should 
C            exist  =>  data should exist for nn*nnv nodes
C          filename - name of file to be read
C
C outputs: zval(i,j) - z coordinate at horizontal node i
C            and vertical node j           
C          u(i,j) - x-component of the vector at horizontal 
C            node i and vertical node j
C          v(i,j) - y-component of the vector at horizontal 
C            node i and vertical node j
C          w(i,j) - z-component of the vector at horizontal 
C            node i and vertical node j
C          freq - frequency in radians/sec
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           30 JULY 1992
C           Revised: 25 APRIL 1994
C-----------------------------------------------------------------------
C
C ARGUMENTS
      real zval(nndim,nnvdim)
      complex u(nndim,nnvdim),v(nndim,nnvdim),w(nndim,nnvdim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
      read(63,*)nnv
      read(63,101)header
      read(63,*)freq
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADVEL:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADVEL:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      do 20 i=1,nndim
         do 10 j=1,nnv
            read(63,*,end=21)n,zval(i,j),uamp,upha,vamp,vpha,wamp,wpha 
            u(i,j)=CMPLX(uamp*COS(-upha),uamp*SIN(-upha))
            v(i,j)=CMPLX(vamp*COS(-vpha),vamp*SIN(-vpha))
            w(i,j)=CMPLX(wamp*COS(-wpha),wamp*SIN(-wpha))
            jj=j
 10      continue
         ii=i
 20   continue
 21   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .vel file and nn in SUBROUTINE LOADVEL.'
         STOP
      else
         write(*,*)ii,'x',jj,' complex 3-D vector values loaded from ',
     &filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADVRT(nndim,nnvdim,nn,nnv,filename,z,u,v,w,
     &rho,q2,q2l,enzm)
C-----------------------------------------------------------------------
C purpose: This routine loads a .vrt file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          nn - number of horizontal nodes for which data should 
C            exist
C          nnv - number of vertical nodes for which data should 
C            exist  =>  data should exist for nn*nnv nodes
C          filename - name of file to be read
C
C outputs: z(i,j) - z coordinate at horizontal node i
C            and vertical node j           
C          u(i,j) - x-component of the vector at horizontal 
C            node i and vertical node j
C          v(i,j) - y-component of the vector at horizontal 
C            node i and vertical node j
C          w(i,j) - z-component of the vector at horizontal 
C            node i and vertical node j
C          rho(i,j) - (density-ref density)/(ref density) at horizontal 
C            node i and vertical node j
C          q2(i,j) - half the turbulent kinetic energy at horizontal 
C            node i and vertical node j
C          q2l(i,j) - q2 times the mixing length at horizontal 
C            node i and vertical node j
C          enzm(i,j) - eddy viscosity at horizontal 
C            node i and vertical node j
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           30 JUL 1992 - Original
C           25 APR 1994 - Revision 1
C           08 JAN 1997 - Revision 2 (comments only)
C-----------------------------------------------------------------------
C
C ARGUMENTS
      real z(nndim,nnvdim)
      real u(nndim,nnvdim),v(nndim,nnvdim),w(nndim,nnvdim)
      real rho(nndim,nnvdim),q2(nndim,nnvdim),q2l(nndim,nnvdim)
      real enzm(nndim,nnvdim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
      read(63,*)nnv
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SURBROUTINE LOADVRT:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADVRT:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      do 20 i=1,nndim
         do 10 j=1,nnv
            read(63,*,end=21)node,z(i,j),u(i,j),v(i,j),w(i,j),
     &                            rho(i,j),q2(i,j),q2l(i,j),enzm(i,j)
            jj=j
 10      continue
         ii=i
 20   continue
 21   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .vrt file and nn in SUBROUTINE LOADVRT.'
         STOP
      else
         write(*,*)ii,'x',jj,' real 3-D vector values loaded from ',
     &filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE LOADVMT(nndim,nnvdim,nn,nnv,filename,z,u,v,w,
     &rho,t,s,q2,q2l,enzm,enzh,enzq)
C-----------------------------------------------------------------------
C purpose: This routine loads a .vmt file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension node arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          nn - number of horizontal nodes for which data should 
C            exist
C          nnv - number of vertical nodes for which data should 
C            exist  =>  data should exist for nn*nnv nodes
C          filename - name of file to be read
C
C outputs: z(i,j) - z coordinate at horizontal node i
C            and vertical node j           
C          u(i,j) - x-component of the vector at horizontal 
C            node i and vertical node j
C          v(i,j) - y-component of the vector at horizontal 
C            node i and vertical node j
C          w(i,j) - z-component of the vector at horizontal 
C            node i and vertical node j
C          rho(i,j) - (density-ref density)/(ref density) at horizontal 
C            node i and vertical node j
C          t(i,j) - temperature at horizontal 
C            node i and vertical node j
C          s(i,j) - salinity at horizontal 
C            node i and vertical node j
C          q2(i,j) - half the turbulent kinetic energy at horizontal 
C            node i and vertical node j
C          q2l(i,j) - q2 times the mixing length at horizontal 
C            node i and vertical node j
C          enzm(i,j) - vertical eddy viscosity at horizontal 
C            node i and vertical node j
C          enzh(i,j) - vertical eddy diffusivity for t and s 
C            at horizontal node i and vertical node j
C          enzq(i,j) - vertical eddy diffusivity for q2 and q2l
C            at horizontal node i and vertical node j
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           08 JAN 1997
C-----------------------------------------------------------------------
C
C ARGUMENTS
      real z(nndim,nnvdim)
      real u(nndim,nnvdim),v(nndim,nnvdim),w(nndim,nnvdim)
      real rho(nndim,nnvdim),t(nndim,nnvdim),s(nndim,nnvdim)
      real q2(nndim,nnvdim),q2l(nndim,nnvdim)
      real enzm(nndim,nnvdim),enzh(nndim,nnvdim),enzq(nndim,nnvdim)
      character*72 filename,header
C
C START OF EXECUTABLE CODE
C
C Open file
      open(63,file=filename,status='old')
C
C Read headers
      read(63,101)header
      read(63,101)header
      read(63,*)nnv
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SURBROUTINE LOADVRT:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE LOADVRT:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Read data
      do 20 i=1,nndim
         do 10 j=1,nnv
            read(63,*,end=21)node,z(i,j),u(i,j),v(i,j),w(i,j),
     &                       rho(i,j),t(i,j),s(i,j),q2(i,j),q2l(i,j),
     &                       enzm(i,j),enzh(i,j),enzq(i,j)
            jj=j
 10      continue
         ii=i
 20   continue
 21   close(63)
C
C Message to standard out
      if(ii.NE.nn)then
         write(*,*)'There is a mismatch between the number of horizontal
     & nodes in your .vmt file and nn in SUBROUTINE LOADVMT.'
         STOP
      else
         write(*,*)ii,'x',jj,' real 3-D vector values loaded from ',
     &filename
      endif
C
C FORMAT STATEMENTS
 101  format(a)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
C***********************************************************************
C***********************************************************************
      SUBROUTINE LST2S3R(nndim,nnvdim,nlevels,nlev,zl,sigtl,
     &nn,nnv,z,sigt)
C-----------------------------------------------------------------------
C purpose: This routine interpolates 3-D level mesh sigmat data to a
C           3-D sigma mesh. 
C
C restrictions: If a sigma mesh node is not within the vertical
C           extent of the level mesh than the level mesh value at
C           the nearest level mesh node is used to specify the sigma
C           mesh value.
C
C index range: i=1,nn, j=1,nnv, l=1,nlev
C
C inputs:  nndim - parametered size of arrays indexed with i
C          nnvdim - parametered size of arrays indexed with j
C          nlevels - parametered size of arrays indexed with l
C          nlev - number of level surfaces in .lst file
C          zl(l) - z coordinate of level mesh nodes
C          sigtl(i,l) - sigmat at level mesh locations
C          nn - number of horizontal nodes
C          nnv - number of vertical nodes in sigma mesh
C          zval(i,j) - sigma mesh z coordinate values
C
C outputs: sigt(i,j) - sigmat at 3-D sigma mesh nodes
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           JANUARY 1, 1993
C           Revised: JUL 27, 1994
C-----------------------------------------------------------------------
C
C global arrays
      real zl(nlevels),sigtl(nndim,nlevels)
      real z(nndim,nnvdim),sigt(nndim,nnvdim)
C
C Begin node loop for interpolation
      do 10 i=1,nn
C
C  Loop over sigma mesh nodes and perform interpolation
         do 10 j=1,nnv
            CALL BASIS1D1(nlev,zl,z(i,j),b2,n2,b1,n1)
C
C notes from BASIS1D1: z(i,j)<zl(1)    => n1=nn,b1=0.0,n2=1,b2=1.0 
C                      z(i,j)>zl(nlev) => n1=nn,b1=1.0,n2=1,b2=0.0 
            sigt(i,j)=b1*sigtl(i,n1)+b2*sigtl(i,n2)
 10   continue
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE M2ELEVSUB(in,x,y,z,zeta,reffile,resfile,
     &nn,nnv,ne,nndim,nnvdim,nedim,ampd,nphad,ampb,nphab)
C-----------------------------------------------------------------------
C purpose: This subroutine interpolates complex surface elevation data
C           from a 2-D computational mesh to observational sites read
C           from a reference file, computes statistics pertaining
C           to the comparison of model and observational data,
C           and writes the results to a data file.
C
C restrictions: 2-D triangular mesh with linear elements
C               currently uses mercator projection mercgom2
C
C index range: i=1,nn, j=1,nnv, k=1,ne
C
C inputs from calling routine:
C         3-D mesh input data
C          in(3,k) - incidence list
C          x(i),y(i) - cartesian horizontal nodal coordinates
C          z(i,j) - 3-D vertical nodal coordinates
C          zeta(i) - horizontal node surface elevation values (COMPLEX)
C          nn - number of horizontal nodes
C          nnv - number of nodes in the vertical
C          ne - number of horizontal elements
C         Dimensioning parameters
C          nndim - parametered size of arrays indexed with i
C          nnvdim - parametered size of arrays indexed with j
C          nedim - parametered size of arrays indexed with k
C         Data files
C          reffile - reference file containing observational data
C                     (refer to GOMPAK for data file format)
C          resfile - data file to which site statistics are written
C
C outputs:Results to resfile
C         Returned to calling routine (See LN93 for definitions)
C          ampd  - average elevation amplitude deviation
C          nphad - average elevation phase deviation
C          ampb  - average elevation amplitude bias
C          nphab - average elevation phase bias
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           MAY 16, 1994
C-----------------------------------------------------------------------
      complex ZETA(nndim)
      integer IN(3,nedim)     
      real X(nndim),Y(nndim),Z(nndim,nnvdim)
      character*72 reffile,resfile
C
C Local assignments
      complex zetap
      real basis(3)
      character*14 place
      character*14 readdata
      character*10 header
      PI=ACOS(-1.0)
      aedsum=0.0
      npdsum=0
      aeesum=0.0
      npesum=0
C
C  Open reference data file
      open(15,file=reffile,status='old')
      open(16,file=resfile,status='unknown')
      rewind(16)
      write(16,*)'M2 Tidal Elevation comparisons with reference data'
      write(16,*)'Reference file:  ',reffile
      write(16,*)' '
      write(16,*)'Site            zaref  zamod  zadev  zpref  zpmod  zpd
     &ev long    lat    nelem  nclosest'
      write(16,*)' '
C
C Enter loop which interpolates to find the elevation at 
C   points specified by the user in a data file.  For each point at
C   which the elevation is desired, the user data file must contain
C   a single line entry consisting of the long and lat coordinates of
C   the point.
      maxpts=nndim
      do 90 k=1,maxpts
C
C Specify place at which the solution is desired and locate the data
C     corresponding to it in the reference file
         readdata=' '
         do while(readdata.NE.'*')
            read(15,103,end=100)readdata
         enddo
         read(15,105)place,plong,plat,amp,pha,ylon,ylat
         CALL MERCGOM2(1,plong,plat,px,py)
         ncref=ncref+1
C
C Call a subroutine to find the basis functions at (px,py)
         CALL BASIS2D(nndim,nedim,in,x,y,nn,ne,px,py,
     &   nclosest,nelem,basis)
C
C If nelem=0, use the elevation of closest node to the output file
         if(nelem.EQ.0)then
            za=ABS(zeta(nclosest))
            zp=phaselagd(zeta(nclosest))
            if(zp.GT.360.0)zp=zp-360.0
C
C Else use weights of basis functions to determine elevation and depth
         else
            node1=in(1,nelem)
            node2=in(2,nelem)
            node3=in(3,nelem)
            zetap=zeta(node1)*basis(1)+zeta(node2)*basis(2)
     &          +zeta(node3)*basis(3)
            bathyp=-Z(node1,1)*basis(1)-Z(node2,1)*basis(2)
     &          -Z(node3,1)*basis(3)
            za=ABS(zetap)
            zp=phaselagd(zetap)
            if(zp.GT.360.0)zp=zp-360.0
         endif
C
C Write model results to CRT
      aerr=za-amp
      nphaerr=NINT(zp)-NINT(pha)
      if(nphaerr.GT.180)nphaerr=nphaerr-360
      if(nphaerr.LT.-180)nphaerr=nphaerr+360
      aedsum=aedsum+ABS(aerr)
      npdsum=npdsum+ABS(nphaerr)
      aeesum=aeesum+aerr
      npesum=npesum+nphaerr
      write(16,122)place,amp,za,aerr,NINT(pha),NINT(zp),nphaerr,
     &plong,plat,px,py,nelem,nclosest
 90   continue
      write(16,*)' Your data file has to many points in it.'
      write(16,*)'   Increase maxpts and recompile the code'
 91   continue
 100  continue
C
C Overall statistics
      ampd=aedsum/REAL(ncref)
      nphad=NINT(REAL(npdsum)/REAL(ncref))
      ampb=aeesum/REAL(ncref)
      nphab=NINT(REAL(npesum)/REAL(ncref))
      write(16,123)ampd,nphad
      write(16,124)ampb,nphab
      write(16,*)ncref
      close(16)
C
C Format statements
 101  format(3f10.3,10i8)
 102  format(10x,3f10.3)
 103  format(a)
 104  format(/,a,' is not on the mesh')
 105  format(a,2f8.2,f7.3,f6.0,2f8.2)
 110  format(i2,8f10.4)
 111  format(8f10.4)
 122  format(a,3f7.3,3i7,2f7.2,2f10.0,2i8)
 123  format(/,'average deviations:         ',f7.3,15x,i6) 
 124  format('error averages:             ',f7.3,15x,i6)
 130  format(a,'Observed     ',f7.3,i7,/,
     &     14x,'Model        ',f7.3,i7,/,
     &     14x,'Difference   ',f7.3,i7,/)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE M2ELLSUB(in,x,y,z,u,v,reffile,resfile,
     &nn,nnv,ne,nndim,nnvdim,nedim,
     &aveumab,aveumib,avephab,aveaorb,aveumar,aveumir,avephar,aveaorr)
C-----------------------------------------------------------------------
C purpose: This subroutine interpolates complex horizontal velocity data
C           from a 3-D computational mesh to observational sites read
C           from a reference file, computes tidal ellipse statistics
C           pertaining to the comparison of model and observational
C           data, and writes the results to a data file.
C
C restrictions: FUNDY/QUODDY style 3-D mesh
C               currently uses mercator projection mercgom2
C
C index range: i=1,nn, j=1,nnv, k=1,ne
C
C inputs from calling routine:
C         3-D mesh input data
C          in(3,k) - incidence list
C          x(i),y(i) - cartesian horizontal nodal coordinates
C          z(i,j) - 3-D vertical nodal coordinates
C          u(i,j),v(i,j) - x,y components of nodal velocities (COMPLEX)
C          nn - number of horizontal nodes
C          nnv - number of nodes in the vertical
C          ne - number of horizontal elements
C         Dimensioning parameters
C          nndim - parametered size of arrays indexed with i
C          nnvdim - parametered size of arrays indexed with j
C          nedim - parametered size of arrays indexed with k
C         Data files
C          reffile - reference file containing observational data
C                     (refer to GOMPAK for data file format)
C          resfile - data file to which site statistics are written
C
C outputs:Results to resfile
C         Returned to calling routine (See LN93 for definitions)
C          aveumab - average major axis velocity bias
C          aveumib - average minor axis velocity bias
C          avephab - average phase bias
C          aveaorb - average orientation bias
C          aveumar - average major axis velocity deviation
C          aveumir - average minor axis velocity deviation
C          avephar - average phase deviation
C          aveaorr - average orientation deviation
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           MAY 16, 1994
C-----------------------------------------------------------------------
C
C Parameter Statement
      parameter (maxpts=10000,nv=21,nen=100)
C
C Global Assignments
      integer in(3,nedim)     
      dimension x(nndim),y(nndim),z(nndim,nnvdim),basis(3)
      complex u(nndim,nnvdim),v(nndim,nnvdim)
C
C Local Assignments
      complex up(nv),vp(nv)
      complex uhere,vhere
      dimension uint(nv),upint(nv),vint(nv),vpint(nv),bint(nv)
      dimension pnorm(nen),umaj(nen),umin(nen),phase(nen),orien(nen)
      character*72 reffile,resfile
      character*14 place
      character*14 readdata
      PI=ACOS(-1.0)
C
C START OF EXECUTABLE CODE
C
C Check for oversize of nnv
      if(nnv.GT.nv)then
      write(*,*)'The number of vertical levels is to large for current p
     &arameters in SUBROUTINE M2ELLSUB.'
      write(*,*)'  => Increase nv to at least ',nnv
      STOP
      endif
C
C Open reference data file
      open(15,file=reffile,status='old')
C
C Open results file
      open(16,file=resfile,status='unknown')
      rewind(16)
      write(16,*)'M2 Tidal Ellipse comparisons with reference data'
      write(16,*)'Reference file:  ',reffile
C
C Enter loop to read M2 tidal ellipse data from file and interpolate
C   model results at that point
      do 90 k=1,maxpts
         batsum=0.0
         umaesum=0.0
         umiesum=0.0
         phaesum=0.0
         aoresum=0.0
         ngages=0
         ncref=0
         umarsum=0
         umirsum=0
         pharsum=0
         aorrsum=0
C
C Move forward in reference data file to next place
 83      readdata=' '
         do while(readdata.NE.'*')
            read(15,103,end=100)readdata
         enddo
         read(15,103)place
         ncref=ncref+1
C
C Read gage reference data and convert (long,lat) location to (x,y)
         read(15,*)plong,plat
         CALL MERCGOM2(1,plong,plat,px,py)
         read(15,*)depth,nent
         do 20 j=1,nent
            read(15,*)pdepth,umaj(j),umin(j),phase(j),orien(j),days,
     &umajeb,umineb,phaeb,aoreb
            if(phase(j).GT.180.0)phase(j)=phase(j)-360.0
            if(orien(j).GT.180.0)orien(j)=orien(j)-360.0
            umarsum=umarsum+umajeb
            umirsum=umirsum+umineb
            pharsum=pharsum+phaeb
            aorrsum=aorrsum+aoreb
            pnorm(j)=MAX(0.0,pdepth/depth)
 20      continue
C
C Determine the value of the basis functions at (xp,yp) resides
         CALL BASIS2D(nndim,nedim,in,x,y,nn,ne,px,py,
     &   nclosest,nelem,basis)
C
C If nelem=0, write to the output file that the point is not on the mesh
         if(nelem.EQ.0)then
            write(16,104)plong,plat
C
C Else use weights of basis functions to determine quantities
         else
C
C   Bathymetry
            node1=in(1,nelem)
            node2=in(2,nelem)
            node3=in(3,nelem)
            bathyp=-z(node1,1)*basis(1)-z(node2,1)*basis(2)
     &          -z(node3,1)*basis(3)
C
C   Vertical structure of M2 Velocities and normalized height
            do 39 jj=1,NNV
               up(jj)=u(node1,jj)*basis(1)+u(node2,jj)*basis(2)
     &          +u(node3,jj)*basis(3)
               vp(jj)=v(node1,jj)*basis(1)+v(node2,jj)*basis(2)
     &          +v(node3,jj)*basis(3)
               batnorm=1.0+(z(node1,jj)*basis(1)+z(node2,jj)*basis(2)
     &          +z(node3,jj)*basis(3))/bathyp
               bint(jj)=batnorm
 39         continue
            bint(1)=0.0
C
C Error results at measurement depths
            write(16,123)place,depth,bathyp
            baterr=bathyp-depth
            batsum=batsum+ABS(baterr)
            do 50 j=1,nent
               do 55 kkk=1,nnv
                  if(pnorm(j).LT.bint(kkk))then
                     n1=kkk-1
                     n2=kkk
                     go to 56
                  endif
 55            continue
 56            continue
               diff1=bint(n2)-pnorm(j)
               diff2=pnorm(j)-bint(n1)
               diffsum=diff1+diff2
C
C Compute x and y components of velocity at measurement location
               uhere=(up(n1)*diff1+up(n2)*diff2)/diffsum
               vhere=(vp(n1)*diff1+vp(n2)*diff2)/diffsum
C
C Convert to model results to tidal ellipse parameters
               CALL ELLIPSE (uhere,vhere,
     &                 umajhere,uminhere,ainc,phashere,apl,amn,gpl,gmin)
               oriehere=90.0-ainc
               if(oriehere.LT.0.0)oriehere=oriehere+360.0
               if(oriehere.GT.180.0)oriehere=oriehere-360.0
               if(phashere.GT.180.0)phashere=phashere-360.0
C
C Compute differences between model results and observational data
               umae=umajhere-umaj(j)
               umie=uminhere-umin(j)
               phae=phashere-phase(j)
               if(phae.GT.180.0)phae=-360.0+phae
               if(phae.LT.-180.0)phae=360.0+phae
               aore=oriehere-orien(j)
               if(aore.GT.180.0)aore=-360.0+aore
               if(aore.LT.-180.0)aore=360.0+aore
C
C   Write this measurement site's results
               write(16,124)pnorm(j)*depth,umaj(j),umae,
     &         umin(j),umie,phase(j),phae,orien(j),aore
C
C Sum errors
               ngages=ngages+1
               umaesum=umaesum+SQRT(umae**2.0)
               umiesum=umiesum+SQRT(umie**2.0)
               phaesum=phaesum+SQRT(phae**2.0)
               aoresum=aoresum+SQRT(aore**2.0)
 50         continue
         endif
C
C End loop
      go to 83
 90   continue
      write(*,*)' Your data file has to many points in it.'
      write(*,*)'   Increase maxpts and recompile the code'
 100  close(15)
C
C  Write gage error results
      aveumar=umarsum/real(ngages)
      aveumir=umirsum/real(ngages)
      avephar=pharsum/real(ngages)
      aveaorr=aorrsum/real(ngages)
      avebater=batsum/real(ncref)
      aveumab=umaesum/real(ngages)
      aveumib=umiesum/real(ngages)
      avephab=phaesum/real(ngages)
      aveaorb=aoresum/real(ngages)
      write(16,125)ncref,avebater,ngages,aveumab,aveumib,
     &avephab,aveaorb
      write(16,126)aveumar,aveumir,avephar,aveaorr
      close(16)
C
C  Format statements
 101  format(3f10.3,10i8)
 102  format(10x,3f10.3)
 103  format(a)
 104  format(2f10.3,' is not on the mesh')
 110  format(i2,8f10.4)
 111  format(8f10.4)
 120  format(//,a,' is on element ',i5,/,
     &'  Reference data:',/,
     &'    Longitude = ',f10.4,/,
     &'    Latitude =  ',f10.4,/,
     &'    Depth =     ',f10.4,//)
 121  format('Node ',i5,' is closest to ',a,/,
     &'  The model M2 results at node ',i5,' are:',/,
     &'    M2 Amplitude = ',f10.4,/,
     &'    M2 Phaselag  = ',f10.4,/,
     &'    Depth        = ',f10.4,//)
 122  format('Model results at ',a,/,
     &'  M2 response:',/,
     &'    M2 Amplitude = ',f10.4,/,
     &'    M2 Phaselag  = ',f10.4,/,
     &'    Depth        = ',f10.4,//,
     &'  Vertical structure:',/,
     &'  normbathy     Umajm  uphalag      vM2     vphalag    wM2     wp
     &halag',/)
 123  format(/,'*',/,'site ',a,/,
     &'     Reference depth =',f6.0,/,
     &'     Model depth     =',f9.3,/,
     &'     Individual gauge reference values and errors.',/,
     &'          above bot    umajr  error  uminf  error   phar  error
     &orienr error')
 124  format(10x,f7.0,f11.3,f7.3,f7.3,f7.3,f7.0,f7.0,f7.0,f7.0)
 125  format(/,'Overall error summary for ',i3,' sites:',/,
     &'     average depth error = ',f7.3,' m',//,
     &'Overall error summary for ',i3,' gages:',/,
     &'     average umaj error  = ',f7.3,' m/sec',/,
     &'     average umin error  = ',f7.3,' m/sec',/,
     &'     average phase error = ',f7.3,' degrees',/,
     &'     average orien error = ',f7.3,' degrees',/)
 126  format(/,'Average deviation in Moody data for all sites:',/,
     &'     ave umaj deviation  = ',f7.3,' m/sec',/,
     &'     ave umin deviation  = ',f7.3,' m/sec',/,
     &'     ave phase deviation = ',f7.3,' degrees',/,
     &'     ave orien deviation = ',f7.3,' degrees',/)
      return
      end
C***********************************************************************
C***********************************************************************
C=======================================================================
C========= ROUTINES OF MERCATOR PROJECTION =============================
C=======================================================================
C SUBROUTINE MERCGOM1
C Provided to NML by D. Greenberg
C Latest Revision by Christopher E. Naimie
C Dartmouth College - 25 NOV 1991
C
C This set of routines was sent to Dartmouth by D. Greenberg.
C   In its present form it performs a mercator projection
C   which is valid for the gom1,gb1, and bf1 meshes to within
C   0.0025 deg (5th sig fig.) for longitude and latitude measurements
C   and to within 200 meters(4th sig fig.) for x and y measurements.
C
C The projection type is set by NOPT:
C   NOPT=1  =>  convert provided (dlong,dlat) to (x,y)
C   NOPT=2  =>  convert provided (x,y) to (dlong,dlat)
C
C Units: XLON is the longitude in degrees, positive east of Grenwich.
C        XLAT is the latitude in degrees, positive north of the Equator.
C        the x and y coordinates (XPOS,YPOS) are in meters.
C-----------------------------------------------------------------------
      SUBROUTINE MERCGOM1(NOPT,XLON,XLAT,XPOS,YPOS)
C
C      scale is specified at the equator
C      R = degrees/radian   S = cm per degree of latitude
C
      DATA A,B/-1.57079632,0.0067226/
      DATA R,S/57.2957795,1.111338e7/
C Set constants
      SCALE=1353100.3
      xoffset=17.1108
      yoffset=28.5281
C
      if(kkk.NE.64)then
         SF=SCALE/S
         RLAT=42.35
         RLON=-71.0333
      kkk=64
      endif
C
      IF(NOPT.EQ.1)then
         YPOS=((VB(XLAT/R)-VB(RLAT/R))*R/SF+yoffset)*10000.0
         XPOS=((XLON-RLON)/SF+xoffset)*10000.0
         RETURN
C
      else IF(NOPT.EQ.2)then
         XLON=((XPOS/10000.0-xoffset)*SF)+RLON
         ABA=((YPOS/10000.0-yoffset)*SF/R)+VB(RLAT/R)
         ABB=A+2.0*ATAN(EXP(ABA))
         ABC=A+2.0*ATAN(EXP(ABA+B*SIN(ABB)))
         XLAT=R*ABC
         RETURN
      else
         PRINT*,'INVALID MERCATER OPTION'
      endif
      RETURN
      END
C=======================================================================
      FUNCTION VB(X)
C *
C * INCREASING LATITUDE IN A MERCATOR PROJECTION
C * X IN RADIANS, VB IN RADIANS
C
      VB=LOG(TAN(0.78539816+.5*X))-0.0067226*SIN(X)
      return
      END
C=======================================================================
C***********************************************************************
C***********************************************************************
C SUBROUTINE mercgom2
C Christopher E. Naimie
C Dartmouth College
C Latest version - 3 MAY 1993
C
C This subroutine performs a mercator projection, using 
C   Boston, MA., USA as the (x,y) origin.
C 
C Units: dlong is the longitude in degrees, positive east of Grenwich.
C        dlat is the latitude in degrees, positive north of the Equator.
C        x and y are in MKS units.
C
C The constants used are:
C      longitude at Boston = -71.03 deg E
C      latitude at Boston  =  42.35 deg N
C      radius of the earth =  6.3675E+6 meters 
C
C The projection type is set by nopt:
C   nopt=1  =>  convert provided (dlong,dlat) to (x,y)
C   nopt=2  =>  convert provided (x,y) to (dlong,dlat)
C-----------------------------------------------------------------------
      SUBROUTINE mercgom2(nopt,dlong,dlat,x,y)
C Set constants and (xo,yo) coordinates of Boston
      r=6.3675E+6                            
      reflong=rad(-71.03)                    
      reflat=rad(42.35)                      
      xo=r*COS(reflat)*reflong
      yo=r*COS(reflat)*LOG((1.0+SIN(reflat))/COS(reflat))
C If nopt=1:  Convert (long,lat) to (x,y) and subtract (xo,yo)
      if(nopt.EQ.1)then
         rlong=rad(dlong)              
         rlat=rad(dlat)
         x=r*COS(reflat)*rlong-xo
         y=r*COS(reflat)*LOG((1.0+SIN(rlat))/COS(rlat))-yo             
         return
C If nopt=2:  Convert (x+xo,y+xo) to (long,lat)
      else if(nopt.EQ.2)then
         rlong=(x+xo)/(r*COS(reflat))
         call newtlat(rlat,y+yo,reflat,r)
         dlong=deg(rlong)
         dlat=deg(rlat)
         return
      else
         write(*,*)'SUBROUTINE mercbos requires nopt be set to 1 or 2.'
         stop
      endif
      end      
C***********************************************************************
C***********************************************************************
      SUBROUTINE NEWTLAT(rlat,y,reflat,r)
C-----------------------------------------------------------------------
C Christopher E. Naimie
C Dartmouth College - 25 NOV 1991
C
C This subroutine uses the Newton-Raphson Method to calculate the 
C   latitude (in radians), given the following information:
C      r=radius of the earth (m)
C      y=y coordinate of the point who's latitude is desired (m/sec)
C      reflat=reference latitude where y is zero (radians)
C The latitude at y is returned as rlat (in radians).
C-----------------------------------------------------------------------
C Set constants
      tol=0.0001
      n=1000
C  Enter iteration loop
      po=reflat
      do 10 i=1,n
         p1=po-((1.0+SIN(po))/COS(po)-EXP(y/(r*COS(reflat))))
     &         /((1.0+SIN(po))/((COS(po))**2.0))
         if(ABS(p1-po).lt.tol)then
           rlat=p1
           return
         endif
         po=p1
 10   continue
C
C  If loop has completed, the method failed.
C
      write(*,*)' A root was not found after ',n,' iterations.'
      return
      end
C**********************************************************************
C**********************************************************************
C Convert degrees to radians
      real function rad(degrees)
      PI=ACOS(-1.0)
      rad=degrees*pi/180.0
      return
      end
C***********************************************************************
C***********************************************************************
C Convert radians to degrees
      real function deg(radians)
      PI=ACOS(-1.0)
      deg=radians*180.0/pi
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE NTRANSPORT(nndim,nedim,nn,x,y,ubar,vbar,bathy,ne,in,
     &nseg,px1,py1,px2,py2,nflag,unmax,transnorm)
C-----------------------------------------------------------------------
C
C purpose: This subroutine computes the transport normal to a vertical
C            slice in a 3-D domain by summing up the transport for 
C            nseg segments of the slice.  The transport of each segment
C            is computed by multiplying the normal velocity by the
C            bathymetry at the center of the segment.  
C
C restrictions: Applicable only for  2-D triangular linear elements
C               currently uses mercator projection mercgom2
C
C index range: i=1,nn, j=1,nnv, k=1,ne, m=0,nseg
C
C inputs from calling routine:
C         Dimensioning parameters
C          nndim - parametered size of arrays indexed with i,m,n
C          nedim - parametered size of arrays indexed with k
C         Horizontal 2-D mesh input data
C          nn - number of nodes
C          x(i),y(i) - cartesian nodal coordinates
C          ubar(i),ybar(i) - nodal x,y components of vertically averaged
C           velocity
C          bathy(i) - nodal values of bathymetric depth
C          ne - number of elements
C          in - incidence list
C         Uniform spacing 2-D vertical slice data       
C          nseg - number of horizontal sections
C         Vertical slice horizontal coordinates
C          (px1,py1) is the location of endpoint 1
C          (px2,py2) is the location of endpoint 2
C         nflag - set to 1 if you want to write output results on the
C          fly to a file opened in the main program
C
C outputs: Some results (used by graf to graph the results) are written
C            to a file opened in the main routine if nflag=1
C          unmax is the maximum normal velocity on the segment
C          transnorm is the transport normal to the segment          
C
C history: Written by Christopher E. Naimie
C          Dartmouth College
C          11 MAY 1993
C          Latest Revision - 26 July 1994
C-----------------------------------------------------------------------
C
C Horizontal 2-D mesh arrays sent to routine from calling routine
      integer in(3,nedim)     
      real x(nndim),y(nndim),bathy(nndim),ubar(nndim),vbar(nndim)
C
C Local arrays
      real basis(3)
C
C START OF EXECUTABLE ROUTINE
C
C Calculate x and y components of the normal unit vector pointing from
C   node 1 to node 2 (the unit normal points to the right of an observer
C   standing on node 1 and looking at node 2)
C
C   Calculate length of this segment
      stot=SQRT((px2-px1)**2.0+(py2-py1)**2.0)
C
C   Calculate x and y components of the normal unit vector
      unitx=(py2-py1)/stot
      unity=(px1-px2)/stot
C
C Divide segment into n sections and locate sampling points at the
C   center of these segments, then compute bathymetry, along-bank 
C   velocities, and along-bank transport for the segment
      transnorm=0.0
      unmax=0.0
      do 10 i=1,nseg
         px=px1+(px2-px1)*(real(i)-0.5)/real(nseg)
         py=py1+(py2-py1)*(real(i)-0.5)/real(nseg)
         s=stot*(1.0-(real(i)-0.5)/real(nseg))
         CALL BASIS2D(nndim,nedim,in,x,y,nn,ne,px,py,
     &nclosest,nelem,basis)
C
C If nelem=0, output to the CRT that the point is not on the mesh
         if(nelem.EQ.0)then
            write(*,*)px,py,'is not on the mesh.'
C
C Else use weights of basis functions to determine quantities at the
C   midpoint of this segment necessary to compute the transport
         else
            CALL POIVAL2D(nndim,nedim,in,nelem,basis,bathy,bpt)
            CALL POIVAL2D(nndim,nedim,in,nelem,basis,ubar,upt)
            CALL POIVAL2D(nndim,nedim,in,nelem,basis,vbar,vpt)
C
C Compute along-bank component of velocity
            unorm=upt*unitx+vpt*unity
            if(ABS(unorm).GT.ABS(unmax))unmax=unorm
C
C Compute normal transport
            unb=unorm*bpt
            transnorm=transnorm+unorm*bpt*stot/real(nseg)
C
C Write results for this segment to a file in /tmp that was opened in 
C   the main program if nflag=1
            if(nflag.EQ.1)write(3,'(i5,6e12.4)')i,px,py,s,-bpt,unorm,unb
         endif
 10   continue
C
C  END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
C*********************************************************************
C*********************************************************************
C
C FUNDY4 FIXED SUBROUTINE WRITTEN BY PROFESSOR DANIEL R. LYNCH
C
      FUNCTION PHASELAG(Z)
C
C COMPUTES THE NEGATIVE ARGUMENT OF A COMPLEX NUMBER Z, IN RADIANS. 
C RESULT IS REPORTED IN THE RANGE 0. TO 2*PI. 
C 
      COMPLEX Z
      PI=ACOS(-1.0) 
      PHASELAG = 0.0
      IF(ABS(Z).GT.0.)  PHASELAG = -ATAN2(AIMAG(Z), REAL(Z))
      IF(PHASELAG.LT.0.) PHASELAG = PHASELAG + 2.*PI
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C*********************************************************************
C*********************************************************************
C
C FUNDY4 FIXED SUBROUTINE WRITTEN BY PROFESSOR DANIEL R. LYNCH
C
      FUNCTION PHASELAGD(Z)
C
C COMPUTES THE NEGATIVE ARGUMENT OF A COMPLEX NUMBER Z, IN DEGREES.
C RESULT IS REPORTED IN THE RANGE 0. TO 360. 
C 
      COMPLEX Z
      PI=ACOS(-1.0) 
      FACTOR=180./PI
      PHASELAGD = 0.0
      IF(ABS(Z).GT.0.)  PHASELAGD = -FACTOR*ATAN2(AIMAG(Z), REAL(Z))
      IF(PHASELAGD.LT.0.) PHASELAGD = PHASELAGD + 360.  
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C      SUBROUTINE SSVELSUB(in,x,y,bathy,z,u,v,reffile,resfile,
C     &nn,nnv,ne,nndim,nnvdim,nedim)
C-----------------------------------------------------------------------
C purpose: This subroutine interpolates the real part of complex
C           horizontal velocity and real depth data from a 3-D
C           computational mesh to observational sites read from a
C           reference file and writes the results to a results file.
C
C restrictions: FUNDY/QUODDY style 3-D mesh
C               currently uses mercator projection mercgom2
C
C index range: i=1,nn, j=1,nnv, k=1,ne
C
C inputs from calling routine:
C         3-D mesh input data
C          in(3,k) - incidence list
C          x(i),y(i) - cartesian horizontal nodal coordinates
C          z(i,j) - 3-D vertical nodal coordinates
C          u(i,j),v(i,j) - x,y components of nodal velocities (COMPLEX)
C          nn - number of horizontal nodes
C          nnv - number of nodes in the vertical
C          ne - number of horizontal elements
C         Dimensioning parameters
C          nndim - parametered size of arrays indexed with i
C          nnvdim - parametered size of arrays indexed with j
C          nedim - parametered size of arrays indexed with k
C         Data files
C          reffile - reference file containing observational data
C                     (refer to GOMPAK for data file format)
C          resfile - data file to which site statistics are written
C
C outputs:Results to resfile
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           JUL 27, 1994
C           DEC 08, 1998 Commented out this relic
C-----------------------------------------------------------------------
C
C Parameter Statement
C      parameter (maxpts=10000,nv=21)
C
C Global Assignments
C      integer in(3,nedim)     
C      real x(nndim),y(nndim),bathy(nndim),z(nndim,nnvdim)
C      complex u(nndim,nnvdim),v(nndim,nnvdim)
C      character*72 reffile,resfile
C
C Local Assignments
C      complex uhere(nv),vhere(nv)
C      dimension zhere(nv)
C      character*72 filename,header
C      character*2 blank
C      character*3 site
C
C START OF EXECUTABLE CODE
C
C Check for oversize of nnv
C      if(nnv.GT.nv)then
C      write(*,*)'The number of vertical levels is to large for current p
C     &arameters in SUBROUTINE SSVELSUB.'
C      write(*,*)'  => Increase nv to at least ',nnv
C      STOP
C      endif
C
C Open reference file
C      open(1,file=reffile,status='old')
C
C Open results file
C      open(3,file=resfile,status='unknown')
C      rewind(3)
C
C Begin interpolation loop
C      do 40 i=1,maxpts
C         read(1,'(a)',end=41)blank
C
C   Read (long,lat) coords and convert to (px,py)
C         if(blank.EQ.'  ')then
C            read(1,'(a)')site
C            read(1,*)dlong,dlat
C            read(1,*)bat,ngage
C            CALL mercgom2(1,dlong,dlat,px,py)
C
C   Find weights of basis functions at (px,py),compute the bathymetry,
C     and compute the velocity profile at (px,py)
C            CALL BASIS2D(nndim,nedim,in,x,y,nn,nele,px,py,nelem,basis)
C            CALL POIVAL2D(nndim,nedim,in,nelem,basis,bathy,bathere)
C            do 20 j=1,nnv
C         CALL POIVAL3DC(nndim,nnvdim,nedim,in,j,nelem,basis,u,uhere(j))
C         CALL POIVAL3DC(nndim,nnvdim,nedim,in,j,nelem,basis,v,vhere(j))
C         CALL POIVAL3D(nndim,nnvdim,nedim,in,j,nelem,basis,z,zhere(j))
C 20         continue
C
C   Loop over reference data and compute model velocity at depth
C            do 30 j=1,ngage
C               read(1,*)bgage,ugage,udev,vgage
C
C   Compute model depth at which results are desired
C               batnorm=(bat-bgage)/bat
C               zgage=-batnorm*bathere
C               write(*,*)zgage,bgage-bat           
C
C   Compute and write bathymetry and velocity results at this gage
C               CALL BASIS1D(nn,zhere,zgage,b2,n2,b1,n1)
C               CALL POIVAL1DC(nndim,uhere,b2,n2,b1,n1,upt)
C               CALL POIVAL1DC(nndim,vhere,b2,n2,b1,n1,vpt)
C               write(3,'(i5,2f10.0,6f10.4)')
C     &                  ngage,px,py,bat,ugage,vgage,
C     &                  bathere,REAL(upt),REAL(vpt)
C 30         continue
C         endif
C 40   continue
C      write(*,*)'Your data file has to many points in it.'
C      write(*,*)'=> Increase maxpts in SSVELSUB and recompile the code.'
C 41   continue
C
C END OF ROUTINE
C 103  format(2f15.0,3f10.4,i5)
C      stop
C      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE VSIGMAMESH(nndim,nedim,nnvdim,nn,x,y,nnv,z,ne,in,
     &nseg,nu,px,py,abs,ord,nele,incd,unitx,unity,stot,bmax,
     &px1,py1,px2,py2)
C-----------------------------------------------------------------------
C purpose: This subroutine creates a 2-D Finite Element Mesh for a
C            vertical slice of a 3-D mesh following the constant
C            sigma surfaces of the 3-D mesh.
C
C restrictions: FUNDY5 style 3-D mesh
C               currently uses mercator projection mercgom2
C
C index range: i=1,nn, j=1,nnv, k=1,ne, m=0,nseg, n=1,nnv*(nseg+1)
C
C inputs from calling routine:
C         Dimensioning parameters
C          nndim - parametered size of arrays indexed with i,m,n
C          nedim - parametered size of arrays indexed with k
C         Horizontal 2-D mesh input data
C          nn - number of nodes
C          x(i),y(i) - cartesian nodal coordinates
C          z(i,j) - vertical nodal coordinates
C          ne - number of elements
C          in - incidence list
C         Vertical slice horizontal coordinates
C          (px1,py1) is the location of endpoint 1
C          (px2,py2) is the location of endpoint 2
C         Uniform spacing 2-D vertical mesh data       
C          nseg - number of horizontal sections
C          nnv - number of nodes in the vertical
C
C outputs:Vertical slice 2-D mesh data
C          bmax - the maximum depth on the vertical slice
C          nu - number of nodes
C          px(m),py(m),ord(n) - cartesian nodal coordinates in physical
C                                 domain
C          abs(n) - horizontal distance of node from endpoint 2  (in km)
C          incd - incidence list 
C          (unitx,unity) are the (x,y) components of the unit normal to
C             the segment
C          stot is the total length of the segment (in m)
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           VSIGMAMESH  - MAY 11, 1993
C-----------------------------------------------------------------------
C
C Horizontal 2-D mesh arrays sent to routine from calling routine
      integer in(3,nedim)
      real x(nndim),y(nndim),z(nndim,nnvdim)
C
C Vertical slice 2-D mesh arrays returned to calling routine
      integer incd(3,nedim)
      real px(0:nndim),py(0:nndim),ord(nndim),abs(nndim)
      real basis(3)
C
C START OF EXECUTABLE ROUTINE
C
C Calculate x and y components of the normal unit vector pointing from
C   node 1 to node 2 (the unit normal points to the right of an observer
C   standing on node 1 and looking at node 2)
C
C   Calculate the total length of the slice
      stot=SQRT((px2-px1)**2.0+(py2-py1)**2.0)
C
C   Calculate x and y components of the normal unit vector
      unitx=(py2-py1)/stot
      unity=(px1-px2)/stot
C
C Divide into n+1 horizontal sampling points and compute
C   the location of the nodes for the vertical mesh
      n=0
      bmax=0.0
      do 20 m=nseg,0,-1
         px(m)=px1+(px2-px1)*(real(m))/real(nseg)
         py(m)=py1+(py2-py1)*(real(m))/real(nseg)
C
C   Get value of horizontal basis functions at (px(m),py(m))
         CALL BASIS2D(nndim,nedim,in,x,y,nn,ne,px(m),py(m),
     &                nclosest,nelem,basis)
C
C   If nelem=0, stop
         if(nelem.EQ.0)then
            write(*,*)'Your vertical 2-D slice does not lie within the d
     &omain of your 3-D mesh.  Execution terminated in SUBROUTINE VSIGMA
     &MESH.'
            stop
C
C   Else, use weights of basis functions to determine the vertical 
C     coordinate at the nnv sigma surfaces for the point (px(m),py(m))
         else
         do 10 j=1,nnv
            n=n+1
            abs(n)=stot*(1.0-real(m)/real(nseg))
            CALL POIVAL3D(nndim,nnvdim,nedim,in,j,nelem,basis,z,ord(n))
            if(j.EQ.1)bmax=MAX(bmax,-ord(n))
 10      continue
         endif
 20   continue
      nu=n
C
C Create the vertical mesh incidence list
      CALL FEMGEN(nndim,nedim,nseg,nnv,ord,abs,nele,incd)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE VUNIMESH(nndim,nedim,nn,x,y,bathy,ne,in,
     &nseg,nnvu,nu,px,py,abs,ord,nele,incd,unitx,unity,stot,bmax,
     &px1,py1,px2,py2)
C-----------------------------------------------------------------------
C purpose: This subroutine creates a 2-D Finite Element Mesh for a
C            vertical slice of a 3-D mesh using uniform spacing in the
C            vertical.
C
C restrictions: FUNDY5 style 3-D mesh
C               currently uses mercator projection mercgom2
C
C index range: i=1,nn, k=1,ne, m=0,nseg, n=1,nnvu*(nseg+1)
C
C inputs from calling routine:
C         Dimensioning parameters
C          nndim - parametered size of arrays indexed with i,m,n
C          nedim - parametered size of arrays indexed with k
C         Horizontal 2-D mesh input data
C          nn - number of nodes
C          x(i),y(i) - cartesian nodal coordinates
C          bathy(i) - bathymetric depth
C          ne - number of elements
C          in - incidence list
C         Vertical slice horizontal coordinates
C          (px1,py1) is the location of endpoint 1
C          (px2,py2) is the location of endpoint 2
C         Uniform spacing 2-D vertical mesh data       
C          nseg - number of horizontal sections
C          nnvu - number of uniformly spaced nodes in the vertical
C          bmax - the maximum depth in the vertical slice
C
C outputs:Vertical slice 2-D mesh data
C          nu - number of nodes
C          px(m),py(m),ord(n) - cartesian nodal coordinates in physical
C                                 domain
C          abs(n) - horizontal distance of node from endpoint 2  (in km)
C          incd - incidence list 
C          (unitx,unity) are the (x,y) components of the unit normal to
C             the segment
C          stot is the total length of the segment (in m)
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           MAY 11, 1993
C-----------------------------------------------------------------------
C
C Horizontal 2-D mesh arrays sent to routine from calling routine
      integer in(3,nedim)
      real x(nndim),y(nndim),bathy(nndim)
C
C Vertical slice 2-D mesh arrays returned to calling routine
      integer incd(3,nedim)
      real px(0:nndim),py(0:nndim),ord(nndim),abs(nndim)
      real basis(3)
C
C START OF EXECUTABLE ROUTINE
C
C Calculate x and y components of the normal unit vector pointing from
C   node 1 to node 2 (the unit normal points to the right of an observer
C   standing on node 1 and looking at node 2)
C
C   Calculate the total length of the slice
      stot=SQRT((px2-px1)**2.0+(py2-py1)**2.0)
C
C   Calculate x and y components of the normal unit vector
      unitx=(py2-py1)/stot
      unity=(px1-px2)/stot
C
C Divide into n+1 horizontal sampling points and compute
C   the location of the nodes for the vertical mesh
      n=0
      do 10 m=nseg,0,-1
         px(m)=px1+(px2-px1)*(real(m))/real(nseg)
         py(m)=py1+(py2-py1)*(real(m))/real(nseg)
C
C   Get value of horizontal basis functions at (px(m),py(m))
         CALL BASIS2D(nndim,nedim,in,x,y,nn,ne,px(m),py(m),
     &                nclosest,nelem,basis)
C
C   If nelem=0, stop
         if(nelem.EQ.0)then
            write(*,*)'Your vertical 2-D slice does not lie within the d
     &omain of your 3-D mesh.  Execution terminated in SUBROUTINE VUNIME
     &SH'
            stop
C
C   Else, use weights of basis functions to determine the bathymetry
C     at the point (px(m),py(m))
         else
            CALL POIVAL2D(nndim,nedim,in,nelem,basis,bathy,bpt)
            bpt=MIN(bpt,bmax)
         endif
C
C   Position nodes in the slice coordinate system
         do 10 j=1,nnvu
            n=n+1
            abs(n)=stot*(1.0-real(m)/real(nseg))
            ord(n)=-bpt*real(nnvu-j)/real(nnvu-1)
 10   continue
      nu=n
C
C Create the vertical mesh
      CALL FEMGEN(nndim,nedim,nseg,nnvu,ord,abs,nele,incd)
C
C END OF ROUTINE
      return
      end
C***********************************************************************
C***********************************************************************
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITELST(nndim,nlevels,filename,mesh,header,zl,sigtl,
     &nn,nlev)
C-----------------------------------------------------------------------
C purpose: This routine writes a .lst file
C
C index range: i=1,nn, l=1,nlev
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          nlevels - parameter used to dimension level surfaces
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          zl(l) - location of level surfaces
C          sigtl(i,l) - value of sigtl at horizontal node i
C            and level surface l
C          nn - number of horizontal nodes for which data exists
C          nlev - number of vertical levels for which data exists
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           6 AUGUST 1994
C-----------------------------------------------------------------------
      character*72 filename,mesh,header
      real zl(nlevels),sigtl(nndim,nlevels)
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITELST:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nlev.GT.nlevels)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITELST:'
         write(*,*)'  nlev exceeds nlevels => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='new')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,*)nlev
      write(7,102)(zl(l),l=1,nlev)
      write(7,103)((sigtl(i,l),l=1,nlev),i=1,nn)
      close(7)
C
C Format Statements
 101  format(a)
 102  format(100f7.0)
 103  format(f7.4)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITES2C(nndim,filename,mesh,header,freq,s,nn)
C-----------------------------------------------------------------------
C purpose: This routine writes a .s2c file
C
C index range: i=1,nn
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          freq - frequency in radians/sec
C          s(i) - complex scalar value at node i
C          nn - number of horizontal nodes for which data exists
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           26 APRIL 1994
C-----------------------------------------------------------------------
      character*72 filename,mesh,header
      complex s(nndim)
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITES2C:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='new')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,102)freq
      write(7,103)(I,ABS(s(I)),phaselagd(s(I)),I=1,nn)
      close(7)
C
C Format Statements
 101  format(a)
 102  format(e14.6)
 103  format(i5,2e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITES2R(nndim,filename,mesh,header,s,nn)
C-----------------------------------------------------------------------
C purpose: This routine writes a .s2r file
C
C index range: i=1,nn
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          s(i) - real scalar value at node i
C          nn - number of horizontal nodes for which data exists
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           26 APRIL 1994
C-----------------------------------------------------------------------
      character*72 filename,mesh,header
      real s(nndim)
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITES2R:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='new')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,103)(I,s(I),I=1,nn)
      close(7)
C
C Format Statements
 101  format(a)
 103  format(i5,e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITEBAT(nndim,filename,bat,nn)
C-----------------------------------------------------------------------
C purpose: This routine writes a .bat file
C
C index range: i=1,nn
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          filename - name of file to be read
C          bat(i) - real scalar value at node i
C          nn - number of horizontal nodes for which data exists
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           1994 APR 26 - WRITES2R
C           1997 FEB 08 - Converted to WRITEBAT
C-----------------------------------------------------------------------
      character*72 filename,mesh,header
      real bat(nndim)
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEBAT:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Write file
      open (unit=7,file=filename,status='new')
      write(7,103)(I,bat(I),I=1,nn)
      close(7)
C
C Format Statements
 101  format(a)
 103  format(i5,e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITES3C(nndim,nnvdim,filename,mesh,header,z,s,nn,nnv,
     &freq)
C-----------------------------------------------------------------------
C purpose: This routine writes a .s3c file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          z(i,j) - z coordinate at horizontal node i
C            and vertical node j
C          s(i,j) - complex scalar value at horizontal node i
C            and vertical node j
C          nn - number of horizontal nodes for which data exists
C          nnv - number of vertical nodes 
C          freq - frequency in radians/sec
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           19 MAY 1995
C-----------------------------------------------------------------------
      character*72 filename,mesh,header
      real z(nndim,nnvdim)
      complex s(nndim,nnvdim)
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITES3C:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITES3C:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='new')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,*)nnv
      write(7,102)freq
      write(7,103)((i,z(i,j),ABS(s(i,j)),phaselagd(s(i,j)),j=1,nnv),
     &i=1,nn)
      close(7)
C
C Format Statements
 101  format(a)
 102  format(e14.6)
 103  format(i5,3e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITES3R(nndim,nnvdim,filename,mesh,header,z,s,nn,nnv)
C-----------------------------------------------------------------------
C purpose: This routine writes a .s3r file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          z(i,j) - z coordinate at horizontal node i
C            and vertical node j
C          s(i,j) - real scalar value at horizontal node i
C            and vertical node j
C          nn - number of horizontal nodes for which data exists
C          nnv - number of vertical nodes 
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           26 APRIL 1994
C-----------------------------------------------------------------------
      character*72 filename,mesh,header
      real z(nndim,nnvdim),s(nndim,nnvdim)
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITES3R:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITES3R:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='new')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,*)nnv
      write(7,103)((i,z(i,j),s(i,j),j=1,nnv),i=1,nn)
      close(7)
C
C Format Statements
 101  format(a)
 103  format(i5,2e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITEV2C(nndim,filename,mesh,header,freq,u,v,nn)
C-----------------------------------------------------------------------
C purpose: This routine writes a .v2c file
C
C index range: i=1,nn
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          freq - frequency in radians/sec
C          u(i) - x-component of complex vector at node i
C          v(i) - y-component of complex vector at node i
C          nn - number of horizontal nodes for which data exists
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           26 APRIL 1994
C-----------------------------------------------------------------------
      character*72 filename,mesh,header
      complex u(nndim),v(nndim)
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEV2C:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='new')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,102)freq
      write(7,103)(I,ABS(u(I)),phaselagd(u(I)),
     &ABS(v(I)),phaselagd(v(I)),I=1,nn)
      close(7)
C
C Format Statements
 101  format(a)
 102  format(e14.6)
 103  format(i5,4e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITEV2R(nndim,filename,mesh,header,u,v,nn)
C-----------------------------------------------------------------------
C purpose: This routine writes a .v2r file
C
C index range: i=1,nn
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          u(i) - x-component of real vector at node i
C          v(i) - y-component of real vector at node i
C          nn - number of horizontal nodes for which data exists
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           26 APRIL 1994
C-----------------------------------------------------------------------
      character*72 filename,mesh,header
      real u(nndim),v(nndim)
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEV2R:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='unknown')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,103)(I,u(I),v(I),I=1,nn)
      close(7)
C
C Format Statements
 101  format(a)
 103  format(i5,2e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITEV3R(nndim,nnvdim,filename,mesh,header,z,u,v,w,
     &nn,nnv)
C-----------------------------------------------------------------------
C purpose: This routine writes a .v3r file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          z(i,j) - z coordinate at horizontal node i
C            and vertical node j
C          u(i,j) - x-component of real vector at horizontal node i
C            and vertical node j
C          v(i,j) - x-component of real vector at horizontal node i
C            and vertical node j
C          w(i,j) - x-component of real vector at horizontal node i
C            and vertical node j
C          nn - number of horizontal nodes for which data exists
C          nnv - number of vertical nodes 
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           26 APRIL 1994
C-----------------------------------------------------------------------
      real z(nndim,nnvdim)
      real u(nndim,nnvdim),v(nndim,nnvdim),w(nndim,nnvdim)
      character*72 filename,mesh,header
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEV3R:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEV3R:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='new')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,*)nnv
      write(7,103)((i,z(i,j),u(i,j),v(i,j),w(i,j),j=1,nnv),i=1,nn)
      close(7)
C
C Format statements
 101  format(a)
 103  format(i5,4e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITEVEL(nndim,nnvdim,filename,mesh,header,freq,z,u,v,w
     &,nn,nnv)
C-----------------------------------------------------------------------
C purpose: This routine writes a .vel file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          freq - frequency in radians/sec
C          z(i,j) - z coordinate at horizontal node i
C            and vertical node j
C          u(i,j) - x-component of complex vector at horizontal node i
C            and vertical node j
C          v(i,j) - x-component of complex vector at horizontal node i
C            and vertical node j
C          w(i,j) - x-component of complex vector at horizontal node i
C            and vertical node j
C          nn - number of horizontal nodes for which data exists
C          nnv - number of vertical nodes 
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           26 APRIL 1994
C-----------------------------------------------------------------------
      real z(nndim,nnvdim)
      complex u(nndim,nnvdim),v(nndim,nnvdim),w(nndim,nnvdim)
      character*72 filename,mesh,header
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEVEL:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEVEL:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='new')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,*)nnv
      write(7,*)'1'
      write(7,102)freq
      write(7,103)((i,z(i,j),
     &                  ABS(u(i,j)),phaselag(u(i,j)),
     &                  ABS(v(i,j)),phaselag(v(i,j)),
     &                  ABS(w(i,j)),phaselag(w(i,j)),j=1,nnv),i=1,nn)
      close(7)
C
C Format statements
 101  format(a)
 102  format(e14.6)
 103  format(i5,7e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITEVRT(nndim,nnvdim,filename,mesh,header,z,u,v,w,
     &rho,q2,q2l,enzm,nn,nnv)
C-----------------------------------------------------------------------
C purpose: This routine writes a .vrt file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          z(i,j) - z coordinate at horizontal node i
C            and vertical node j           
C          u(i,j) - x-component of the vector at horizontal 
C            node i and vertical node j
C          v(i,j) - y-component of the vector at horizontal 
C            node i and vertical node j
C          w(i,j) - z-component of the vector at horizontal 
C            node i and vertical node j
C          rho(i,j) - (density-ref density)/(ref density) at horizontal 
C            node i and vertical node j
C          q2(i,j) - half the turbulent kinetic energy at horizontal 
C            node i and vertical node j
C          q2l(i,j) - q2 times the mixing length at horizontal 
C            node i and vertical node j
C          enzm(i,j) - eddy viscosity at horizontal 
C            node i and vertical node j
C          nn - number of horizontal nodes for which data exists
C          nnv - number of vertical nodes 
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           26 APR 1994 - Original
C           08 JAN 1997 - Revised comments
C-----------------------------------------------------------------------
      real z(nndim,nnvdim)
      real u(nndim,nnvdim),v(nndim,nnvdim),w(nndim,nnvdim)
      real rho(nndim,nnvdim)
      real q2(nndim,nnvdim),q2l(nndim,nnvdim),enzm(nndim,nnvdim)
      character*72 filename,mesh,header
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEVRT:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEVRT:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='new')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,*)nnv
      write(7,103)((i,z(i,j),u(i,j),v(i,j),w(i,j),
     &rho(i,j),q2(i,j),q2l(i,j),enzm(i,j),j=1,nnv),i=1,nn)
      close(7)
C
C Format statements
 101  format(a)
 103  format(i5,8e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITEVMT(nndim,nnvdim,filename,mesh,header,z,u,v,w,
     &rho,t,s,q2,q2l,enzm,enzh,enzq,nn,nnv)
C-----------------------------------------------------------------------
C purpose: This routine writes a .vmt file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          z(i,j) - z coordinate at horizontal node i
C            and vertical node j           
C          u(i,j) - x-component of the vector at horizontal 
C            node i and vertical node j
C          v(i,j) - y-component of the vector at horizontal 
C            node i and vertical node j
C          w(i,j) - z-component of the vector at horizontal 
C            node i and vertical node j
C          rho(i,j) - (density-ref density)/(ref density) at horizontal 
C            node i and vertical node j
C          t(i,j) - temperature at horizontal 
C            node i and vertical node j
C          s(i,j) - salinity at horizontal 
C            node i and vertical node j
C          q2(i,j) - half the turbulent kinetic energy at horizontal 
C            node i and vertical node j
C          q2l(i,j) - q2 times the mixing length at horizontal 
C            node i and vertical node j
C          enzm(i,j) - vertical eddy viscosity at horizontal 
C            node i and vertical node j
C          enzh(i,j) - vertical eddy diffusivity for t and s 
C            at horizontal node i and vertical node j
C          enzq(i,j) - vertical eddy diffusivity for q2 and q2l
C            at horizontal node i and vertical node j
C          nn - number of horizontal nodes for which data exists
C          nnv - number of vertical nodes 
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           08 JAN 1997
C-----------------------------------------------------------------------
      real z(nndim,nnvdim)
      real u(nndim,nnvdim),v(nndim,nnvdim),w(nndim,nnvdim)
      real rho(nndim,nnvdim),t(nndim,nnvdim),s(nndim,nnvdim)
      real q2(nndim,nnvdim),q2l(nndim,nnvdim)
      real enzm(nndim,nnvdim),enzh(nndim,nnvdim),enzq(nndim,nnvdim)
      character*72 filename,mesh,header
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEVMT:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEVMT:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='new')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,*)nnv
      write(7,103)((i,z(i,j),u(i,j),v(i,j),w(i,j),rho(i,j),t(i,j),s(i,j)
     &,q2(i,j),q2l(i,j),enzm(i,j),enzh(i,j),enzq(i,j),j=1,nnv),i=1,nn)
      close(7)
C
C Format statements
 101  format(a)
 103  format(i5,12e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE WRITEQ4D(nndim,nnvdim,filename,mesh,header,z,u,v,w,
     &rho,t,s,q2,q2l,enzm,enzh,enzq,nn,nnv)
C-----------------------------------------------------------------------
C purpose: This routine writes a .q4d file
C
C index range: i=1,nn, j=1,nnv
C
C inputs:  nndim - parameter used to dimension nodal arrays in the
C            calling routine
C          nnvdim - parameter used to dimension the number of 
C            vertical nodes in the calling routine
C          filename - name of file to be read
C          mesh - name of the mesh
C          header - character string describing file contents
C          z(i,j) - z coordinate at horizontal node i
C            and vertical node j           
C          u(i,j) - x-component of the vector at horizontal 
C            node i and vertical node j
C          v(i,j) - y-component of the vector at horizontal 
C            node i and vertical node j
C          w(i,j) - z-component of the vector at horizontal 
C            node i and vertical node j
C          rho(i,j) - (density-ref density)/(ref density) at horizontal 
C            node i and vertical node j
C          t(i,j) - temperature at horizontal 
C            node i and vertical node j
C          s(i,j) - salinity at horizontal 
C            node i and vertical node j
C          q2(i,j) - half the turbulent kinetic energy at horizontal 
C            node i and vertical node j
C          q2l(i,j) - q2 times the mixing length at horizontal 
C            node i and vertical node j
C          enzm(i,j) - vertical eddy viscosity at horizontal 
C            node i and vertical node j
C          enzh(i,j) - vertical eddy diffusivity for t and s 
C            at horizontal node i and vertical node j
C          enzq(i,j) - vertical eddy diffusivity for q2 and q2l
C            at horizontal node i and vertical node j
C          nn - number of horizontal nodes for which data exists
C          nnv - number of vertical nodes 
C 
C file format: See CEN 3/29/93 Memorandum
C
C history:  Written by Christopher E. Naimie
C           Dartmouth College
C           08 JAN 1997
C-----------------------------------------------------------------------
      real z(nndim,nnvdim)
      real u(nndim,nnvdim),v(nndim,nnvdim),w(nndim,nnvdim)
      real rho(nndim,nnvdim),t(nndim,nnvdim),s(nndim,nnvdim)
      real q2(nndim,nnvdim),q2l(nndim,nnvdim)
      real enzm(nndim,nnvdim),enzh(nndim,nnvdim),enzq(nndim,nnvdim)
      character*72 filename,mesh,header
C
C Check for oversize of arrays
      nflag=0
      if(nn.GT.nndim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEQ4D:'
         write(*,*)'  nn exceeds nndim => rectify and recompile'
         nflag=1
      endif
         if(nnv.GT.nnvdim)then
	 write(*,*)'Dimensioning problem in SUBROUTINE WRITEQ4D:'
         write(*,*)'  nnv exceeds nnvdim => rectify and recompile'
         nflag=1
      endif
      if(nflag.EQ.1)stop
C
C Use SUBROUTINE CSTRING to extract nonblank part of character strings
      CALL CSTRING(filename,lfs,lfe)
      CALL CSTRING(mesh,lms,lme)
C
C Write file
      open (unit=7,file=filename(lfs:lfe),status='new')
      write(7,101)mesh(lms:lme)
      write(7,101)header
      write(7,*)nnv
      write(7,103)((i,z(i,j),u(i,j),v(i,j),w(i,j),rho(i,j),t(i,j),s(i,j)
     &,q2(i,j),q2l(i,j),enzm(i,j),enzh(i,j),enzq(i,j),j=1,nnv),i=1,nn)
      close(7)
C
C Format statements
 101  format(a)
 103  format(i5,12e14.6)
      return
      end
C***********************************************************************
C***********************************************************************
      SUBROUTINE ICQ4READ(FILICQ4,MESHICQ4,NNICQ4,NNVICQ4,
     &DELTICQ4,IDD0,IMM0,IYEAR0,SEC0,HMID,UMID,VMID,HOLD,UOLD,VOLD,
     &ZMID,ZOLD,UZMID,VZMID,WZMID,Q2MID,Q2LMID,TMID,SMID,NNDIM,NNVDIM)
C-----------------------------------------------------------------------
C Objectives: Read a hot-start .icq4 file
C             Ensure the .icq4 file was written using QUODDY4
C             Ensure array sizes are within with dimensioning parameters
C
C Complete Array Documentation: See main program QUODDY4_1.1
C
C Index Range: I=1,NNICQ4; J=1,NNVICQ4
C               NNICQ4 - number of horizontal nodes in the .icq4 file
C               NNVICQ4 - the number of vertical nodes in the .icq4 file
C
C Inputs: FILICQ4 - the name of the .icq4 hot-start file
C         NNDIM - dimensioned array size for index I
C         NNVDIM - dimensioned array size for index J
C
C Outputs: All outputs contain information related specifications from
C          the .icq4 file
C
C         MESHICQ4 - the name of the geometric mesh
C         NNICQ4 - number of horizontal nodes
C         NNVICQ4 - number of vertical nodes
C         DELTICQ4 - time step size
C         IDD0,IMM0,IYEAR0,SEC0 - timing parameters for the beginning
C                                 of the simulation
C
C       *OLD arrays are initialized with dependent variable data at one
C       time step prior to the beginning of the simulation
C
C         HOLD(I) - total depth
C         UOLD(I),VOLD(I) - x,y components of vertically averaged
C                           horizontal velocity
C         ZOLD(I,J) - 3-D nodal grid
C
C       *MID arrays are initialized with dependent variable data at the
C       beginning of the simulation  
C
C         HMID(I) - total depth
C         UMID(I),VMID(I) - x,y components of vertically averaged
C                           horizontal velocity
C         ZMID(I,J) - 3-D nodal grid
C         UZMID(I,J),VZMID(I,J),WZMID(I,J) - x,y,z components of 
C                                            velocity
C         Q2MID(I,J),Q2LMID(I,J) - twice the turbulent kinetic energy
C                                  and the master length scale times
C                                  twice the turbulent kinetic energy
C         TMID(I,J),SMID(I,J) - temperature and salinity
C-----------------------------------------------------------------------
C
C Global dimensioning and assignments
C
      REAL HOLD(NNDIM),UOLD(NNDIM),VOLD(NNDIM),ZOLD(NNDIM,NNVDIM)
      REAL HMID(NNDIM),UMID(NNDIM),VMID(NNDIM),ZMID(NNDIM,NNVDIM),
     &UZMID(NNDIM,NNVDIM),VZMID(NNDIM,NNVDIM),WZMID(NNDIM,NNVDIM),
     &Q2MID(NNDIM,NNVDIM),Q2LMID(NNDIM,NNVDIM),
     &TMID(NNDIM,NNVDIM),SMID(NNDIM,NNVDIM)
      CHARACTER*72 FILICQ4,MESHICQ4
C
C Local assignments
C
      CHARACTER*72 MODICQ4,COMICQ4
C
C START OF EXECUTABLE CODE
C
C Open the .icq4 file for "HOT-START" Initialization
C
      INDX=INDEX(FILICQ4,' ')-1
      OPEN(UNIT=27,FILE=FILICQ4(1:INDX),FORM='FORMATTED',STATUS='OLD')
C
C Read the model code from the first line of the .icq4 file and make
C sure it is 'QUODDY4'
C
      READ(27,'(A)')MODICQ4
      INDX=INDEX(MODICQ4,' ')-1
      IF(MODICQ4(1:INDX).NE.'QUODDY4')THEN
         WRITE(2,'(A)')'EXECUTION TERMINATED IN SUBROUTINE ICQ4READ'
         WRITE(2,'(5A)')'QUODDY4 CANNOT BE HOT-STARTED WITH A ',
     &                   MODICQ4(1:INDX),' .icq* FILE.'
         STOP
      ENDIF
C
C Read the mesh name from the second line of the .icq4 file
C
      READ(27,'(A)')MESHICQ4
C
C Read and ignore the following three comment lines from the .icq4 file
C
      DO I=1,2
         READ(27,'(A)')COMICQ4
      ENDDO
C
C Read in the number of nodes in the horizontal and vertical
C dimensions and check whether they are compatiable with dimensioning
C parameters
C
      READ(27,*)NNICQ4,NNVICQ4
      ISTOP=0
      IF(NNICQ4.GT.NNDIM) THEN
         ISTOP=1
         WRITE(2,'(A)')'NNICQ4 = ',NNICQ4
         WRITE(2,'(A)')'THE NUMBER OF HORIZONTAL NODES IN .icq4 FILE EXC
     &EEDS NNDIM'
      ENDIF
      IF(NNVICQ4.GT.NNVDIM) THEN
         ISTOP=1
         WRITE(2,'(A)')'NNVICQ4 = ',NNVICQ4
         WRITE(2,'(A)')'THE NUMBER OF VERTICAL NODES IN .icq4 FILE EXCEE
     &DS NNVDIM'
      ENDIF
      IF(ISTOP.EQ.1)THEN
         WRITE(2,'(A)')'EXECUTION TERMINATED IN SUBROUTINE ICQ4READ'
         STOP
      ENDIF
C
C Read in time step label, current simulation time, and time-step size
C
      READ(27,*)IDD0,IMM0,IYEAR0,SEC0,DELTICQ4
C
C Read in the 2-D data: HMID, UMID, VMID, HOLD, UOLD, VOLD
C
      READ(27,*)(HMID(I),UMID(I),VMID(I),HOLD(I),UOLD(I),VOLD(I),
     &I=1,NNICQ4)
C
C Read in the 3-D data: ZMID,ZOLD,UZMID,VZMID,WZMID,Q2MID,
C                              Q2LMID,TMID,SMID
C
      READ(27,*)((ZMID(I,J),ZOLD(I,J),UZMID(I,J),VZMID(I,J),WZMID(I,J),
     &Q2MID(I,J),Q2LMID(I,J),TMID(I,J),SMID(I,J),I=1,NNICQ4),
     &J=1,NNVICQ4)
C
C The .icq4 file has been successfully read
C
      INDX=INDEX(FILICQ4,' ')-1
      WRITE(2,'(/A)')'     '//FILICQ4(1:INDX)//' successfully read'
      CLOSE(27)
C
C END OF ROUTINE
C
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE ICQ4WRITE(CASNAM,FILINQ,FILICQ,FILOUT,
     &KDMID,SECMID,DELT,HMID,UMID,VMID,HOLD,UOLD,VOLD,ZMID,ZOLD,
     &UZMID,VZMID,WZMID,Q2MID,Q2LMID,TMID,SMID,NN,NNV,NNDIM,NNVDIM)
C-----------------------------------------------------------------------
C   Description: This subroutine is used to output all the required
C                data to a ".icq4" file for the "hot start" from the
C                current status.
C     Variables: [Argument list]
C                CASNAM -- Casename (mesh name) of the simulation;
C                        there should be mesh data files associated
C                        with this casename
C                FILINQ -- Filename of maximum 45 characters
C                FILICQ -- Filename of maximum 45 characters of the
C                        previous ".icq4" file
C                FILOUT -- Output ".icq4" file for the next "hot start"
C 	         KDMID is the day number of the current date based on
C 	            the Gregorian calendar (KDMID=1 is January 1, 0000)
C                   idd0,imm0,iyear0
C                SECMID is current time on day KDMID, in seconds after 
C                   midnight.
C                HMID(*), UMID(*), VMID(*) -- Sea surface and 2-D vel.
C                        at time t
C                ZMID(NNDIM,*) -- Vertical coordinate at current time
C                UZMID(NNDIM,*), VZMID(NNDIM,*), WZMID(NNDIM,*) -- 3-D
C                        velocity solution at the current time step
C                Q2MID(NNDIM,*), Q2LMID(NNDIM,*) -- 3-D turbulence
C                        kinetic energy and its product with the
C                        mixing length at the current time step
C                        velocity solution at the current time step
C                TMID(NNDIM,*), SMID(NNDIM,*) -- 3-D temperature
C                        and salinity solution
C                DELT -- Time step size, dt in hrs.
C                HOLD(*), UOLD(*), VOLD(*) -- Sea surface and 2-D vel.
C                        at time t-dt
C                ZOLD(NNDIM,*) -- Vertical coordinate at t-dt
C                HDOWN(*) -- Bathymetric depth at nodes
C                NN -- Actual number of nodes in the horizontal mesh
C                NNDIM -- Maximum number of nodes allowed in the
C                        horizontal mesh
C                NNV -- Total number of nodes along the vertical
C                [Local integer variables]
C                I, J -- Do loop indices
C      Accuracy: I*2, R*4 (single precision)
C         Input: All the variables in the argument list
C        Output: A ".icq4" files for the next "hot start" from a
C                previous simulation
C-----------------------------------------------------------------------
      CHARACTER FILOUT*(*)
      CHARACTER*72 CASNAM
      CHARACTER*72 FILICQ,FILINQ
      REAL DELT, SECMID
      REAL HMID(*),UMID(*),VMID(*),HOLD(*),UOLD(*),VOLD(*),
     &     ZMID(NNDIM,*),ZOLD(NNDIM,*),UZMID(NNDIM,*),
     &     VZMID(NNDIM,*),WZMID(NNDIM,*),Q2MID(NNDIM,*),
     &     Q2LMID(NNDIM,*),TMID(NNDIM,*),SMID(NNDIM,*)
C
C BEGINNING OF EXECUTABLE ROUTINE
C
C Open output ".icq4" file
C
      OPEN(UNIT=20,FILE=FILOUT,FORM='FORMATTED',STATUS='UNKNOWN')
      REWIND(20)
C
C Write the first five lines of the output, ".icq4" file
C
      WRITE(20,11)'QUODDY4'
      INDX=INDEX(CASNAM,' ')-1
      WRITE(20,11)CASNAM(1:INDX)
      INDX=INDEX(FILINQ,' ')-1
      WRITE(20,11)'Input file:         '//FILINQ(1:INDX)
      INDX=INDEX(FILICQ,' ')-1
      WRITE(20,11)'Initial condition:  '//FILICQ(1:INDX)
C
C Write the number of nodes in the horizontal and in the vertical
C dimensions
C
      WRITE(20,13)NN,NNV
C
C Write time step label, current simulation time, and previous time
C
      CALL DMY(IDD,IMM,IYEAR,KDMID)
      WRITE(20,12)IDD,IMM,IYEAR,SECMID,DELT
C
C Write the 2-D data: HMID, UMID, VMID, HOLD, UOLD, VOLD
C
      WRITE(20,16)(HMID(I),UMID(I),VMID(I),HOLD(I),UOLD(I),
     &              VOLD(I),I=1,NN)
C
C Write the 3-D data: ZMID, ZOLD, UZMID, VZMID, WZMID
C
      WRITE(20,17)((ZMID(I,J),ZOLD(I,J),UZMID(I,J),VZMID(I,J),
     &              WZMID(I,J),Q2MID(I,J),Q2LMID(I,J),TMID(I,J),
     &              SMID(I,J),I=1,NN),J=1,NNV)
      CLOSE(20)
C
C Output format statements
C
 11   FORMAT(A)
 12   FORMAT(1x,2(I2,1x),i4,2(1X,f21.12))
 13   FORMAT(I8,1X,I8)
 14   FORMAT(5X,A11,I7,A4,A45)
 15   FORMAT(27X,A)
 16   FORMAT(6E17.9)
 17   FORMAT(9E17.9)
C
C END OF ROUTINE
C
      RETURN
      END
C***********************************************************************
C***********************************************************************
C END OF GOMPAK
C END OF GOMPAK
C***********************************************************************
C***********************************************************************
C***********************************************************************
C***********************************************************************
C BEGINNING OF IOSPAK
C BEGINNING OF IOSPAK
C***********************************************************************
C***********************************************************************
C
C IOSPAK
C
C***********************************************************************
C***********************************************************************
c      SUBROUTINE VUF(kd0,KOnk,xlat,fk,vuk,freqk)
c taken from Mike Foreman's IOS subroutine Tide1.f
C alterations by Wendy Gentleman,   July 1995
C  1) ONE OR MORE RECORDS FOR EACH MAIN CONSTITUENT CONTAINING THE
C     FOLLOWING INFORMATION IN FORMAT (6X,A5,1X,6I3,F5.2,I4)
C      KON    = CONSTITUENT NAME
C   II,JJ,KK,LL,MM,NN = THE SIX DOODSON NUMBERS
C      SEMI   = PHASE CORRECTION
C      NJ     = THE NUMBER OF SATELLITES FOR THIS CONSTITUENT.
C   IF NJ>0, INFORMATION ON THE SATELLITE CONSTITUENTS IS READ , THREE
C   SATELLITES PER CARD, IN THE FORMAT (11X,3(3I3,F4.2,F7.4,1X,I1,1X)).
C   FOR EACH SATELLITE THE VALUES READ ARE
C      LDEL,MDEL,NDEL = THE CHANGES IN THE LAST THREE DOODSON NUMBERS
C                       FROM THOSE OF THE MAIN CONSTITUENT.
C      PH     = THE PHASE CORRECTION
C      EE     = THE AMPLITUDE RATIO OF THE SATELLITE TIDAL POTENTIAL TO
C               THAT OF THE MAIN CONSTITUENT.
C      IR     = 1 IF THE AMPLITUDE RATIO HAS TO BE MULTIPLIED BY THE
C                 LATITUDE CORRECTION FACTOR FOR DIURNAL CONSTITUENTS
C               2 IF THE AMPLITUDE RATIO HAS TO BE MULTIPLIED BY THE
C                 LATITUDE CORRECTION FACTOR FOR SEMI-DIURNAL CONSTI-
C                 TUENTS.
C               OTHERWISE IF NO CORRECTION IS REQUIRED TO THE AMPLITUDE
C                 RATIO.
C
C  2) ONE BLANK RECORD
C
C  3) ONE RECORD FOR EACH SHALLOW WATER CONSTITUENT SPECIFYING IN FORMAT
C     (11X,3(3I3,F4.2,F7.4,1X,I1,1X)), THE FOLLOWING INFORMATION
C      KON    = NAME  OF THE SHALLOW WATER CONSTITUENT
C      NJ     = NUMBER OF MAIN CONSTITUENTS FROM WHICH IT IS DERIVED.
C      COEF,KONCO = COMBINATION NUMBER AND NAME OF THESE MAIN
C                   CONSTITUENTS.
C
C  4) ONE BLANK RECORD
C
C=======================================================================
C
C*  MTOT           IS THE NUMBER OF CONSTITUENTS INCLUDED IN THE DATA
C*                 FILE. AT PRESENT THIS IS 146.
C*  M              IS THE NUMBER OF CONSTITUENTS INCLUDED IN THE
C*                 ANALYSIS. AT PRESENT IT WILL HAVE A MAXIMUM OF 69 +
C                  THE NUMBER OF SHALLOW WATER CONSTITUENTS SPECIALLY
C*                 DESIGNATED FOR INCLUSION (NOT IN THE STANDARD 69
C*                 CONSTITUENT PACKAGE) IN THE ANALYSIS.
C*  KONTAB(I)      IS THE ARRAY CONTAINING ALL THE CONSTITUENT NAMES AS
C*                 THEY ARE READ IN FROM THE DATA FILE. IT SHOULD HAVE
C*                 THE MINIMUM DIMENSION MTOT.
C*  KON(I)         IS THE ARRAY CONTAINING THE NAMES OF ALL THE
C*                 CONSTITUENTS THAT ARE TO BE INCLUDED IN THE LEAST
C*                 SQUARES ANALYSIS TO THE TIDAL RECORD. THEY ARE CHOSEN
C*                 FROM THE KONTAB LIST VIA THE RAYLEIGH CRITERION. THE
C*                 ARRAY SHOULD HAVE DIMENSION AT LEAST M.
C*  FREQ(I)        IS THE ARRAY OF FREQUENCIES (CYCLES/ HR.) CORRESPOND-
C*                 ING TO THE CONSTITUENTS CONTAINED IN KONTAB. IT
C*                 SHOULD HAVE DIMENSION AT LEAST MTOT.
C*  SIG(I)         IS THE ARRAY OF FREQUENCIES CORRESPONDING TO THE
C*                 CONSTITUENTS CONTAINED IN KON. IT SHOULD HAVE MINIMUM
C*                 DIMENSION M.
C*  V              ASTRONOMICAL PHASE ARGUMENT
C*  U & F          NODAL MODULATION &PHASE AND AMPLITUDE CORRECTIONS
C
C Right now these (v, u & f) are calculated mtot constituents
C
C MINIMAL DIMENSION REQUIREMENTS
C ==============================
C THE DIMENSION OF
C   KON AND NJ SHOULD BE AT LEAST EQUAL TO THE TOTAL NUMBER OF POSSIBLE
C   CONSTITUENTS PLUS ONE (PRESENTLY 146+1), THE DIMENSION OF II, JJ,
C   KK, LL, MM, NN, AND SEMI SHOULD BE AT LEAST EQUAL TO THE NUMBER OF
C   MAIN CONSTITUENTS PLUS ONE (PRESENTLY 45+1), THE DIMENSION OF EE,
C   LDEL, MDEL, NDEL, IR, AND PH SHOULD BE AT LEAST EQUAL TO THE TOTAL
C   NUMBER OF SATELLITES TO ALL THE MAIN CONSTITUENTS PLUS THE NUMBER
C   OF CONSTITUENTS WITH NO SATELLITES (PRESENTLY 162+8 IF THERE ARE NO
C   THIRD ORDER SATELLITES FOR BOTH N2 AND L2, AND 167+8 IF ALL THIRD
C   ORDER SATELLITES ARE INCLUDED FOR BOTH N2 AND L2),
C   AND THE DIMENSION OF KONCO, AND COEFF SHOULD BE AT LEAST EQUAL TO
C   THE SUM FOR ALL SHALLOW WATER CONSTITUENTS OF THE NUMBER OF MAIN
C   CONSTITUENTS FROM WHICH EACH IS DERIVED,PLUS FOUR (PRESENTLY 251+4).
C=======================================================================
C
      SUBROUTINE VUF(kh,KOnk,xlat,fk,vuk,freqk)
      CHARACTER*5 KONk,KBLANK,KONCO,kontab(170)
      REAL freq(170),f(170),vu(170),fk,vuk,sigk
      real*8 d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp,hh,tau,dtau
      real EE(205),PH(205),SEMI(50)
      real xlat
      integer kh, line
      integer II(50),JJ(50),KK(50),LL(50),MM(50),NN(50),indx
      integer LDEL(205),MDEL(205),NDEL(205),IR(205),NJ(170)
      integer ntotal, ntidal
      DIMENSION KONCO(320),COEF(320)
      DATA KBLANK/'     '/

      Save kontab, freq, konco, 
     &              ee, ph, semi, ii, jj, kk, ll, mm, nn,
     &             ldel, mdel, ndel, ir, nj, coef, ntotal,
     &             ntidal

C
c in opnvuf - reads in kontab and data calls falls to setvuf
c in setvuf - evaluates f and vu for all constituents in kontab
c in vuf - finds appropriate f,vu and sig for a specified constituent

c determines the index for the specified constituents
        do 209 l=1,ntotal
	  if(konk.eq.kontab(l)) then
	    indx=l
          go to 211 
          end if
 209	continue
	  write(*,*) 'specified constituent',konk,'is not in file'
C	  stop
 211    continue

        fk=f(indx)
        vuk=vu(indx)
        freqk=freq(indx)

c        write(*,*) konk,vuk*360.,fk,freqk
 98   format(' ',a5,5x,2f12.5)
	
      RETURN


      ENTRY OPNVUF(Kh,KONk,XLAT,fk,vuk,freqk)	

      KR=8
      PI=3.1415926536
      TWOPI=2.*PI

      open(unit=kr,file='IOS_tidetbl',status='old',form='formatted') 


C***********************************************************************
C*  HERE THE MAIN CONSTITUENTS AND THEIR DOODSON NUMBERS ARE READ IN
C*  FORMAT (6X,A5,1X,6I3,F5.2,I4). THE VALUES ARE RESPECTIVELY
C*     KON    = CONSTITUENT NAME
C*  II,JJ,KK,LL,MM,NN = THE SIX DOODSON NUMBERS
C*     SEMI   = PHASE CORRECTION
C*     NJ     = THE NUMBER OF SATELLITES FOR THIS CONSTITUENT.
C*  THE END OF ALL MAIN CONSTITUENTS IS DENOTED BY A BLANK CARD.
C

      JBASE=0
      DO 90 K=1,1000
      READ(KR,60)KONTAB(K),II(K),JJ(K),KK(K),LL(K),
     & MM(K),NN(K),SEMI(K),NJ(K)
   60 FORMAT(6X,A5,1X,6I3,F5.2,I4)
      IF(KONTAB(K).eq.KBLANK) go to 100
70    J1=JBASE+1
      IF(NJ(K).GE.1) GO TO 75
      NJ(K)=1
      JL=J1
      PH(J1)=0.
      EE(J1)=0.
      LDEL(J1)=0
      MDEL(J1)=0
      NDEL(J1)=0
      IR(J1)=0
      GO TO 90
   75 JL=JBASE+NJ(K)
C
C***********************************************************************
C*  IF NJ>0, INFORMATION ON THE SATELLITE CONSTITUENTS IS READ , THREE
C*  SATELLITES PER CARD, IN THE FORMAT (11X,3(3I3,F4.2,F7.4,1X,I1,1X)).
C*  FOR EACH SATELLITE THE VALUES READ ARE
C*     LDEL,MDEL,NDEL = THE CHANGES IN THE LAST THREE DOODSON NUMBERS
C*                      FROM THOSE OF THE MAIN CONSTITUENT.
C*     PH     = THE PHASE CORRECTION
C*     EE     = THE AMPLITUDE RATIO OF THE SATELLITE TIDAL POTENTIAL TO
C*              THAT OF THE MAIN CONSTITUENT.
C*     IR     = 1 IF THE AMPLITUDE RATIO HAS TO BE MULTIPLIED BY THE
C*                LATITUDE CORRECTION FACTOR FOR DIURNAL CONSTITUENTS
C*              2 IF THE AMPLITUDE RATIO HAS TO BE MULTIPLIED BY THE
C*                LATITUDE CORRECTION FACTOR FOR SEMI-DIURNAL CONSTI-
C*                TUENTS.
C*              OTHERWISE IF NO CORRECTION IS REQUIRED TO THE AMPLITUDE
C*                RATIO.
C

      READ(KR,80)(LDEL(J),MDEL(J),NDEL(J),PH(J),EE(J),IR(J),J=J1,JL)
   80 FORMAT((11X,3(3I3,F4.2,F7.4,1X,I1,1X)))

90    JBASE=JL
100   NTIDAL=K-1		!for us this will be 45

C
C***********************************************************************
C*  THE SHALLOW WATER CONSTITUENTS AND THE MAIN CONSTITUENTS FROM WHICH
C*  THEY ARE DERIVED ARE READ IN HERE WITH THE FORMAT
C*  (6X,A5,I1,2X,4(F5.2,A5,5X)). THE VALUES ARE RESPECTIVELY
C*     KON    = NAME  OF THE SHALLOW WATER CONSTITUENT
C*     NJ     = NUMBER OF MAIN CONSTITUENTS FROM WHICH IT IS DERIVED.
C*     COEF,KONCO = COMBINATION NUMBER AND NAME OF THESE MAIN
C*                  CONSTITUENTS.
C*  THE END OF THESE CONSTITUENTS IS DENOTED BY A BLANK CARD.
C
      JBASE=0
      K1=NTIDAL+1
      DO 160 K=K1,1000
      J1=JBASE+1
      J4=J1+3

      READ(KR,130)KONTAB(K),NJ(K),(COEF(J),KONCO(J),J=J1,J4)
  130 FORMAT(6X,A5,I1,2X,4(F5.2,A5,5X))
      IF(KONTAB(K).eq.KBLANK) go to 170
160   JBASE=JBASE+NJ(K)
170   NTOTAL=K-1		! for us this will be 146

c
c   CLOSE THE DATA FILE
c
      CLOSE(kr)
C
C***********************************************************************
C*  NTIDAL IS THE NUMBER OF MAIN CONSTITUENTS
C*  NTOTAL IS THE NUMBER OF CONSTITUENTS (MAIN + SHALLOW WATER)
C*  FOR  THE GIVEN TIME KH, THE TABLE OF F AND V+U VALUES IS
C*  CALCULATED FOR ALL THE CONSTITUENTS.
C*     F IS THE NODAL MODULATION ADJUSTMENT FACTOR FOR AMPLITUDE
C*     U IS THE NODAL MODULATION ADJUSTMENT FACTOR FOR PHASE
C*     V IS THE ASTRONOMICAL ARGUMENT ADJUSTMENT FOR PHASE.
C

       ENTRY SETVUF(kh,KONk,XLAT,fk,vuk,freqk)    !this will find f, vu etc but also needs indexes first

      SLAT=SIN(PI*XLAT/180.)	

C
C***********************************************************************
C*  THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION
C*  AT THE MID POINT OF THE ANALYSIS PERIOD.
C*     DS,DH,DP,DNP,DPP ARE THEIR RESPECTIVE RATES OF CHANGE OVER A 365
C*     DAY PERIOD AS OF 000 ET 1/1/1976.
       
      d1=kh/24.d0
      call gday(31,12,1899,kd)
      d1=d1-dfloat(kd)-0.5d0
      call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp)
      INT24=24
      INTDYS=KH/INT24
      HH=dfloat(KH-INTDYS*INT24)
      TAU=HH/24.D0+H-S
      dtau=365.d0+dh-ds


C
C***********************************************************************
C*  ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU-
C*  TING THE LUNAR TIME TAU.
C

      JBASE=0
      DO 210 K=1,ntidal

        FREQ(k)=(II(K)*DTAU+JJ(K)*DS+KK(K)*DH+LL(K)*DP+MM(K)*DNP+
     1          NN(K)*DPP)/(365.*24.)

        VDBL=II(k)*TAU+JJ(k)*S+KK(k)*H+LL(k)*P+
     &          MM(k)*ENP+NN(k)*PP+SEMI(k)

        IV=VDBL
        IV=(IV/2)*2
        V=VDBL-IV
        J1=JBASE+1
        JL=JBASE+NJ(k)
        SUMC=1.
        SUMS=0.

        DO 200 J=J1,JL
C
C***********************************************************************
C*  HERE THE SATELLITE AMPLITUDE RATIO ADJUSTMENT FOR LATITUDE IS MADE
C

          RR=EE(J)
          L=IR(J)+1
          GO TO (901,902,903),L
 902      RR=EE(J)*0.36309*(1.-5.*SLAT*SLAT)/SLAT
          GO TO 901
 903      RR=EE(J)*2.59808*SLAT
 901      CONTINUE
          UUDBL=LDEL(J)*P+MDEL(J)*ENP+NDEL(J)*PP+PH(J)
          IUU=UUDBL
          UU=UUDBL-IUU
          SUMC=SUMC+RR*COS(UU*TWOPI)
          SUMS=SUMS+RR*SIN(UU*TWOPI)

  200   CONTINUE

        F(K)=SQRT(SUMC*SUMC+SUMS*SUMS)
        VU(K)=V+ATAN2(SUMS,SUMC)/TWOPI
	
210   JBASE=JL

C
C***********************************************************************
C*  HERE F AND V+U OF THE SHALLOW WATER CONSTITUENTS ARE COMPUTED FROM
C*  THE VALUES OF THE MAIN CONSTITUENT FROM WHICH THEY ARE DERIVED.
C

      JBASE=0
      K1=NTIDAL+1
      IF(k1.gt.NTOTAL) RETURN
      DO 270 K=K1,NTOTAL
        F(K)=1.0
        VU(K)=0.0
        FREQ(k)=0.
        iflag=1
	go to 268
 268  J1=JBASE+1
      JL=JBASE+NJ(K)
      DO 260 J=J1,JL
        KM1=K-1
        DO 240 L=1,KM1
          IF(KONTAB(L).eq.KONCO(J)) go to 250
 240    CONTINUE
        WRITE(LP,241)KONCO(J)
 241    FORMAT('   SETVUF STOP.',A5)
        STOP
 250  F(K)=F(K)*F(L)**ABS(COEF(J))
      VU(K)=VU(K)+COEF(J)*VU(L)
      if (iflag.eq.1) FREQ(k)=FREQ(k)+COEF(J)*FREQ(l)
 260   continue
 270  JBASE=JL

      RETURN
      END

	subroutine astr(d1,h,pp,s,p,np,dh,dpp,ds,dp,dnp)
c	this subroutine calculates the following five ephermides
c	of the sun and moon
c	h = mean longitude of the sum
c	pp = mean longitude of the solar perigee
c	s = mean longitude of the moon
c	p = mean longitude of the lunar perigee
c	np = negative of the longitude of the mean ascending node
c	and their rates of change.
c	Units for the ephermides are cycles and for their derivatives
c	are cycles/365 days
c	The formulae for calculating this ephermides were taken from
c	pages 98 and 107 of the Explanatory Supplement to the
c	Astronomical Ephermeris and the American Ephermis and
c	Nautical Almanac (1961)
c
	implicit real*8(a-h,o-z)
	real*8 np
	d2=d1*1.d-4
	f=360.d0
	f2=f/365.d0
	h=279.696678d0+.9856473354d0*d1+.00002267d0*d2*d2
	pp=281.220833d0+.0000470684d0*d1+.0000339d0*d2*d2+
     1  .00000007d0*d2**3
	s=270.434164d0+13.1763965268d0*d1-.000085d0*d2*d2+
     1  .000000039d0*d2**3
	p=334.329556d0+.1114040803d0*d1-.0007739d0*d2*d2-
     1  .00000026d0*d2**3
	np=-259.183275d0+.0529539222d0*d1-.0001557d0*d2*d2-
     1  .00000005d0*d2**3
	h=h/f
	pp=pp/f
	s=s/f
	p=p/f
	np=np/f
	h=h-dint(h)
	pp=pp-dint(pp)
	s=s-dint(s)
	p=p-dint(p)
	np=np-dint(np)
	dh=.9856473354d0+2.d-8*.00002267d0*d1
	dpp=.0000470684d0+2.d-8*.0000339d0*d1
     1  +3.d-12*.00000007d0*d1**2
	ds=13.1763965268d0-2.d-8*.000085d0*d1+
     1  3.d-12*.000000039d0*d1**2
	dp=.1114040803d0-2.d-8*.0007739d0*d1-
     1  3.d-12*.00000026d0*d1**2
	dnp=+.0529539222d0-2.d-8*.0001557d0*d1-
     1  3.d-12*.00000005d0*d1**2
	dh=dh/f2
	dpp=dpp/f2
	ds=ds/f2
	dp=dp/f2
	dnp=dnp/f2
	return
	end


	subroutine decompose(elev,ih1,id1,im1,iyear1,ihl,idl,
     &                      iml,iyearl,lad,lam,
     &                      nn,obsfac,m,kon)
	integer dev
      character*5 KONTAB,KBLANK,KSTN,NA,IREF,KON,KONIN,DDUM,KO,KMPR
c      character*5 NKON,NNKON,NKMPR
      character*1 icn
      character*5 KONAN
	real elev(7000,700)
      DIMENSION KONAN(20),KONINo(20),R(20),ZETA(20)
      DIMENSION SIGAN(20),SIGINo(20),nnkon(77),nkmpr(77)
      DIMENSION NA(4),LSTRP(10)
      DIMENSION KONTAB(170),KON(100),C(100),S(100),FREQ(170),KMPR(170)
     1,SIG(100),ERC(100),ERS(100),NKON(15),A(100),EPS(100),XP(18000)
      COMMON Z(18000),IHH1,IDD1,IMM1,IYY1,ICC1,IHHL,IDDL,IMML,IYYL,
     1ICCL,KH1
      dimension AA(100),GD(100),KO(100)
      DATA KBLANK/'     '/
      DEGREE(CYC)=(CYC-IFIX(CYC)-SIGN(.5,CYC)+.5)*360.

	open(unit=8,file='IOS_tidetbl',status='old',form='formatted')
	rewind(8)

C will have to change filenames/comments if want s2c files

C* THE PRESENT PROGRAM (ORIGINALLY PART OF THE TIDAL ANALYSIS CODE 
C *FROM MIKE FOREMAN AT IOS) WAS REVISED BY WENDY GENTLEMAN AUGUST 1995
C*
C* i have removed the rayleigh crieteon test and the inference. 
C* currently the output is in the form of an s2c file without the
C* header information. you may also want to construct filenames.
C***********************************************************************
C*  FILE REFERENCE NUMBERS OF DEVICES REQUIRED BY THIS PROGRAM
C*      KR  - INPUT FILE  - CONTAINS THE TIDAL CONSTITUENT INFORMATION.
C*      MTD - INPUT FILE  - GIVES TIDAL STATION AND ANALYSIS TYPE
C*                          DETAILS ALONG WITH THE HOURLY HEIGHTS.
C*      LP  - OUTPUT FILE - LINE PRINTER.
C*      KP  - OUTPUT FILE - CONTAINS THE ANALYSIS RESULTS, IF SO
C*                          REQUESTED.
C*      7   - OUTPUT FILE - CONTAINS RESULTS FOR ALPHATEXT OR
C*                          FLEXOWRITER, IF SO REQUESTED.
C*      9   - OUTPUT FILE - TEMPORARY DISC FILE FOR STORING PRELIMINARY
C*                          OUTPUT AND TERMINATING THE PROGRAM.
C*      KPR - OUTPUT FILE - IF SO REQUESTED, CONTAINS HOURLY SYNTHESIZED
C*                          VALUES BASED ON ANALYSIS RESULTS.
C*  PRESENTLY KR,MTD,LP,KP, AND KPR ARE ASSIGNED THE RESPECTIVE  NUMBERS
C*  8,4,6,2, AND 10.  SEE THE MANUAL, OR COMMENT STATEMENTS WITHIN
C*  WITHIN THIS PROGRAM FOR FURTHER DETAILS ON THEIR USE.
C*
C***********************************************************************
C*  IF THE SAMPLING INTERVAL OF THE ORIGINAL DATA IS OTHER THAN
C*  ONE HOUR, THEN THE RECORD SHOULD BE FILTERED AND DECIMATED TO HOURLY
C*  INTERVALS, PRIOR TO SUBMISSION TO THIS PROGRAM. G GODIN SUGGESTS THE
C*  SEQUENCE OF MOVING AVERAGE FILTERS A12*A12*A13 FOR 5 MINUTE DATA,
C*  AND A6*A6*A7 FOR 10 MINUTE DATA.
C*
C***********************************************************************
C*  ARRAY DEFINITIONS AND DIMENSION GUIDELINES.
C*
C*  MTOT           IS THE NUMBER OF CONSTITUENTS INCLUDED IN THE DATA
C*                 FILE. AT PRESENT THIS IS 146.
C*  M              IS THE NUMBER OF CONSTITUENTS INCLUDED IN THE
C*                 ANALYSIS. AT PRESENT IT WILL HAVE A MAXIMUM OF 69 +
C                  THE NUMBER OF SHALLOW WATER CONSTITUENTS SPECIALLY
C*                 DESIGNATED FOR INCLUSION (NOT IN THE STANDARD 69
C*                 CONSTITUENT PACKAGE) IN THE ANALYSIS.
C*  KONTAB(I)      IS THE ARRAY CONTAINING ALL THE CONSTITUENT NAMES AS
C*                 THEY ARE READ IN FROM THE DATA FILE. IT SHOULD HAVE
C*                 THE MINIMUM DIMENSION MTOT.
C*  KON(I)         IS THE ARRAY CONTAINING THE NAMES OF ALL THE
C*                 CONSTITUENTS THAT ARE TO BE INCLUDED IN THE LEAST
C*                 SQUARES ANALYSIS TO THE TIDAL RECORD. THEY ARE CHOSEN
C*                 FROM THE KONTAB LIST VIA THE RAYLEIGH CRITERION. THE
C*                 ARRAY SHOULD HAVE DIMENSION AT LEAST M.
C*  C(I) & S(I)    ARE THE ARRAYS CONTAINING THE COS AND SIN COEFFICIENTS
C*                 OF THE I-TH CONSTITUENT AS FOUND VIA THE LEAST
C*                 SQUARES ANALYSIS. THEIR MINIMUM DIMENSION SHOULD BE
C*                 M.
C*  SIG(I)         IS THE ARRAY OF FREQUENCIES CORRESPONDING TO THE
C*                 CONSTITUENTS CONTAINED IN KON. IT SHOULD HAVE MINIMUM
C*                 DIMENSION M.
C*  ERC(I) & ERS(I) ARE THE ARRAYS CONTAINING ESTIMATES OF THE ERRORS
C*                 (STANDARD DEVIATIONS) FOR THE VALUES CONTAINED IN THE
C*                 ARRAYS C(I) & S(I) RESPECTIVELY. THEIR MINIMUM
C*                 DIMENSION SHOULD BE M.
C*  Z(I)           IS THE ARRAY CONTAINING ALL THE HOURLY HEIGHTS OF THE
C*                 DATA RECORD. IT HAS BEEN GIVEN THE DIMENSION SIZE OF
C*                 9000 WHICH IS SUFFICIENT FOR RECORDS OF LENGTH UP TO
C*                 ONE YEAR.
C*  XP(I)          IS THE ARRAY CONTAINING THE SYNTHESIZED HOURLY
C*                 HEIGHTS BASED ON THE ANALYSIS RESULTS.  PREDICTIONS
C*                 ARE SPECIFIED FOR THE ANALYSIS PERIOD, INCLUDING
C*                 THOSE INTERVALS WHERE THERE WERE GAPS IN THE ORIGINAL
C*                 RECORD.  AS WITH Z, THIS ARRAY HAS BEEN GIVEN THE
C*                 DIMENSION SIZE OF 9000.
C*  AS(I,J)        IS THE TWO DIMENSIONAL ARRAY CONTAINING THE UPPER
C*                 TRIANGLE AND DIAGONAL OF THE  ARRAY
C*                 RESULTING FROM THE LEAST SQUARES FIT OF CONSTITUENT
C*                 AMPLITUDE AND PHASE TO THE HOURLY RECORD. IT SHOULD
C*                 HAVE A MINIMUM DIMENSION OF 2*M-1 BY 2*M-1.
C*  A(I) & EPS(I)  ARE THE ARRAYS CONTAINING THE AMPLITUDE AND PHASE FOR
C*                 CONSTITUENT KON(I) AS FOUND VIA THE LEAST SQUARES
C*                 ANALYSIS. THEY SHOULD HAVE A MINIMUM DIMENSION OF
C*                 M.
C*  KO(I)          IS THE ARRAY CONTAINING THE NAMES OF ALL THE CONSTI-
C*                 TUENTS IN KON AND INFERRED FROM THOSE IN KON. ITS
C*                 MINIMUM DIMENSION SHOULD BE M.
C*  AA(I) & GD(I)  ARE THE ARRAYS CONTAINING THE AMPLITUDE AND PHASE FOR
C*                 CONSTITUENT KO(I) AFTER CORRECTIONS FOR NODAL MODULA-
C*                 TION, ASTRONOMICAL ARGUMENT AND INFERRED CONSTITUENT.
C*                 THEIR MINIMUM DIMENSION SHOULD BE M.
C***********************************************************************
C
C
C JOB INITIALIZATION
C
c these paramters can be treated as constants for our purposes
      KR=8
      KP=2
      LP=6
      MTD=4
      KPR=10
	nin=0
	indy=8
      indic=0	
      iout1=2
	zoff=0.0
C* Here we set the variables for the common block
       ihh1=ih1
       idd1=id1
       imm1=im1
       icc1=int(iyear1/100)
       iyy1=iyear1-icc1*100
       
       ihhl=ihl
       iddl=idl
       imml=iml
       iccl=int(iyearl/100)
       iyyl=iyearl-iccl*100
       	

C*     INDY   = 8 INDICATES AN ANALYSIS IS DESIRED FOR THE UPCOMING
C*                 PERIOD.
C*              0 INDICATES NO FURTHER ANALYSES ARE DESIRED.
C*     INDIC  = 1 IF J CARD OUTPUT IS DESIRED
C*              OTHERWISE IF NOT.
C*     IOUT1  = 6 IF ONLY LINE PRINTER LISTING OF RESULTS IS DESIRED.
C*              2 IF CARD OUTPUT AND LISTING ARE BOTH DESIRED. 
C*		    this has been changed to not give line printer listing
C*     ZOFF   = CONSTANT VALUE TO BE SUBTRACTED FROM ALL THE HOURLY
C*              HEIGHTS.
c
c these remaining paramters can be ignored for our purposes
c na(j), j=1,4
c itzone
c lod, lom
c iref
c ichk
c indpr
c nstrp
c kstn
c na
c itzone
C*     NA     = STATION NAME
C*     ITZONE = TIME ZONE OF HOURLY HEIGHTS.
C*     LAD,LAM= LATITUDE IN DEGREES & MINUTES OF THE TIDAL STATION
C*     LOD,LOM= LONGITUDE IN DEGREES & MINUTES OF THE TIDAL STATION
C*     IREF   = REFERENCE STATION NUMBER.
C*     ICHK   = 0 IF THE HOURLY HEIGHTS INPUT DATA IS TO BE CHECKED FOR
C*                ERRORS
C*              1 IF NO CHECKING IS DESIRED.
C*     OBSFAC = THE FACTOR, IF DIFFERENT FROM .01, THAT WILL MULTIPLY
C*              THE INTEGER HOURLY OBSERVATIONS IN ORDER TO PRODUCE THE
C*              DESIRED UNITS FOR THE FINAL CONSTITUENT AMPLITUDES.
C*     INDPR  = 1 IF HOURLY HEIGHT PREDICTIONS BASED ON THE
C*                ANALYSIS RESULTS, ARE TO BE CALCULATED AND WRITTEN
C*                ONTO DEVICE KPR.
C*                IF THERE IS INFERENCE, THIS PARAMETER VALUE WILL
C*                ALSO GIVE THE ROOT MEAN SQUARE RESIDUAL ERROR AFTER
C*                INFERENCE ADJUSTMENTS HAVE BEEN MADE.
C*            = 0 IF NO SUCH PREDICTIONS ARE DESIRED.
C*     NSTRP  = THE NUMBER OF SUCCESSIVE MOVING AVERAGE FILTERS THAT
C*              HAVE BEEN APPLIED TO THE ORIGINAL DATA. IF
C*              NSTRP IS NONZERO, THEN SUITABLE AMPLITUDE CORRECTIONS
C*              WILL BE MADE TO COMPENSATE FOR THE SMOOTHING EFFECT
C*              OF THE FILTERS.
C*
C*  IF NSTRP IS GREATER THAN ZERO, THEN READ FROM DEVICE MTD, THE
C*  PARAMETER, TIMINT AND THE ARRAY (LSTRP(I),I=1,NSTRP), IN THE FORMAT
C*  (F10.5,10I5).
C*      TIMINT = THE SAMPLING INTERVAL, IN MINUTES, OF THE ORIGINAL
C*               UNFILTERED RECORD.
C*      LSTRP  = THE ARRAY CONTAINING THE NUMBER OF TERMS USED IN EACH
C*               OF THE NSTRP SUCCESSIVE MOVING AVERAGE FILTERS.	
c **********************************************************************

      IF(OBSFAC.LT.1.E-8) OBSFAC=1.0
      PI=3.1415926536
      TWOPI=2.*PI

C***********************************************************************
C* CONSTITUENTS, FREQUENCIES, & RAYLEIGH COMPARISON PAIRS ARE READ ON
C* DEVICE KR.
C
c      DO 1020 K=1,1000
c      READ(KR,1010) KONTAB(K),FREQ(K),KMPR(K)
c 1010 FORMAT(4X,A5,3X,F13.10,4X,A5)
c      IF(KONTAB(K).eq.KBLANK) goto 1040
c1020  CONTINUE
c1040  MTOT=K-1
C
C
C***********************************************************************
C*  CONSTITUENTS OTHER THAN THOSE IN THE STANDARD 69 MEMBER PACKAGE
C*  CAN BE SPECIFIED NOW ON DEVICE MTD ALONG WITN THEIR RAYLEIGH COMPAR-
C*  ISON CONSTITUENT (WHICH SHOULD BE IN THE STANDARD OR NOW AUGMENTED
C*  DATA PACKAGE). IF THE RAYLEIGH COMPARISON CONSTITUENT IS MISSING
C*  THE ADDITIONAL CONSTITUENT WILL NOT BE INCLUDED IN THE LEAST SQUARES
C*  FIT.  THE FORMAT IS  (6X,A5,4X,A5) AND A BLANK CARD DENOTES THE END
C*  OF THESE ADDITIONAL CONSTITUENTS.
C

c	do i=1,naddt

c      DO 998 K=1,MTOT
c      IF(KONTAB(K).EQ.NNKON(i)) GO TO 997
c 998  CONTINUE
c      WRITE(LP,996) NNKON(i)
c  996 FORMAT(5X,'CONSTITUENT',2X,A5,2X,'IS NOT INCLUDED IN THE LIST OF
c     1 POSSIBLE ADDITIONAL CONSTITUENTS')
c      STOP
c  997 KMPR(K)=NKMPR(i)
c      NADD=NADD+1
c      NKON(NADD)=NNKON(i)
c  995 CONTINUE
c	end do
C

C***********************************************************************
C*  UNLESS SPECIFIED OTHERWISE, A STATION LATITUDE OF 50 DEGREES IS
C*  ASSUMED FOR THE PURPOSE OF CALCULATING SATELLITE TO MAIN
C*  CONSTITUENT AMPLITUDE RATIOS.
C
C
      XLAT=LAD+ISIGN(LAM,LAD)/60.
      IF(ABS(XLAT).LT.5.) XLAT=SIGN(5.,XLAT)
      IF(IDD1)1080,1070,1080
1070  STOP

C
C***********************************************************************
C*   HERE THE NUMBER OF USEABLE OBSERVATIONS (NOBSU) & THE TIME OF THE
C*   MIDDLE OBSERVATION ARE FOUND.
C
1080  CALL GDAY(IDD1,IMM1,IYear1,KD)
      KH1=KD*24+IHH1
      CALL GDAY(IDDL,IMML,IYearL,KD)
      KHL=KD*24+IHHL
      NOBS=KHL-KH1+1
      NOBSU=((NOBS-1)/2)*2+1
      KHM=KH1+NOBSU/2
      KD=KHM/24
      IHHM=KHM-24*KD
      CALL DMY(IDDM,IMMM,IYearM,KD)
C
C***********************************************************************
C*  HERE V (= ASTRONOMICAL PHASE ARGUMENT), U & F (NODAL MODULATION
C*  PHASE AND AMPLITUDE CORRECTIONS) ARE CALCULATED FOR ALL MTOT
C*  CONSTITUENTS.
C
      CALL SETVUF(KHM,DDUM,xlat, dum, DUM,DUM)
C
C
C***********************************************************************
C   DETERMINE USABLE CONSTITUENTS ACCORDING TO THE RAYLEIGH CRITERION.
C   M IS THE NUMBER FOUND

      do k=1,m
	  call vuf(idum,kon(k),dum, dum, dum, sig(k))
      end do

C
C***********************************************************************
C   READ IN DATA TO BE ANALYZED
C
      do 1050 nodes=1,nn
	n=nobsu
      istn=nodes
	do i=1,n
	 z(i)=elev(nodes,i)*obsfac
	end do

       IF(N.EQ.0) GO TO 4000
C
C***********************************************************************
C   FIND THE LEAST SQUARES FIT
C
      IND=INDPR
      IF(IND.EQ.1.AND.NIN.GT.0) IND=0
      CALL SCFIT2(Z,N,SIG,M,IND,C,S,ERC,ERS,G,NX,AVX,SDX,RT,RA,XP)
C
C
C***********************************************************************
C*  CHANGE RESULTS TO POLAR FORM IN ARRAYS A AND EPS.
C*  OUTPUT RESULTS ON BOTH PRINTER AND PUNCH. OUTPUT FIRST WITHOUT
C*  INFERENCE AND THEN WITH INFERENCE IF THERE IS ANY.
C
      DO 5005 K=1,M
      AK=SQRT(C(K)*C(K)+S(K)*S(K))
      EPS(K)=ATAN2(S(K),C(K))/TWOPI
5005  A(K)=AK
      MIN=M
      NMAX=2

      DO 5350 NOYES=1,NMAX 
C
C***********************************************************************
C*  OUTPUT FOR EACH CONSTITUENT IN TURN
C*  NUMOUT IS THE NUMBER OF CONSTITUENTS LISTED IN THE OUTPUT (THOSE
C*  CHOSEN VIA RAYLEIGH CRITERION AND THOSE INFERRED).
C
      NUMOUT=0

      DO 5300 K=1,M
      AAN=A(K)
      EPSAN=EPS(K)
c this was changed to print only one page
      IF(NOYES.EQ.1) GO TO 5300
C
C***********************************************************************
C* No inferred constituents included

	konin=kblank
C
C***********************************************************************
C*  OUTPUT WITHOUT INFERENCE
C
 5220 CALL VUF(KH,KON(K),dum, f, VU,dum)
      NUMOUT=NUMOUT+1
      AA(NUMOUT)=A(K)/F
      GD(NUMOUT)=DEGREE(EPS(K)+VU)
      EPSD=DEGREE (EPS(K))
      KO(NUMOUT)=KON(K)
      AW=AA(NUMOUT)
      GW=GD(NUMOUT)
	dev=19+k
 5355 WRITE(dev,*) ISTN,AW,GW
 5300  CONTINUE

 5350   continue
 1050   continue
 4000  continue
      return
      END





      SUBROUTINE SCFIT2(X,NIN,F,M,IND,C,S,ERC,ERS,G,NX,AVREM,SDX,RT,RA,X
     1P)
C     ------------------------------------------------------------------
C        THIS SUBROUTINE FINDS THE LEAST SQUARES FIT TO AN EQUALLY
C     SPACED TIME SERIES USING SINES AND COSINES OF SPECIFIED FREQ-
C     UENCIES AS FITTING FUNCTIONS. THERE MAY BE GAPS IN THE DATA SERIES
C
C  INPUTS
C  ------
C   --X(I),I=1...NIN  THE DATA SERIES TO BE FITTED. IF THERE ARE GAPS IN
C     THE DATA , THE X VALUES IN THE GAPS SHOULD BE SET TO 1.E35 .
C   --NIN = THE NUMBER OF POINTS IN SERIES X INCLUDING GAPS .
C     NIN SHOULD BE AN ODD NUMBER . IF IT IS NOT THE LAST X VALUE
C     WILL BE COMPLETELY IGNORED BY THE ANALYSIS .
C   --F(K),K=1...M  THE FREQUENCIES OF THE SIN AND COS COMPONENTS USED
C     IN THE ANALYSIS IN CYCLES PER TIME INCREMENT. IF THE ZERO
C     FREQUENCY IS USED IT MUST BE THE FIRST OF THE SET (IE F(1)=0.0)
C   --M = NUMBER OF FREQUENCIES IN THE ANALYSIS.
C   --IND = 0 IF THE CALCULATION OF RA AND XP IS TO BE BYPASSED.
C         = 1 IF RA AND XP ARE TO BE CALCULATED.
C         = 2 IF RA AND XP ONLY ARE TO BE CALCULATED FROM THE INPUTS X,
C                NIN,F,M,C, AND S. (IE ANALYSIS IS BYPASSED AND
C                PREDICTIONS ARE MADE FROM GIVEN C AND S ARRAYS.)
C
C  OUTPUTS
C  -------
C   --C(K),S(K),K=1...M ARE THE AMPLITUDES OF THE COS AND SIN COMPONENTS
C     OF THE FIT ...
C   --ERC(K),ERS(K),K=1...M ARE THE EXPECTED ERRORS IN C AND S .
C   --G IS THE CONDITION OF THE MATRIX OF NORMAL EQUATIONS .
C       = 1.0 FOR A PERFECT DIAGONAL MATRIX .
C       = 0.0 FOR A SINGULAR MATRIX (IE NO SOLUTION POSSIBLE)
C   --NX,AVX,SDX ARE THE NUMBER OF VALID DATA POINTS IN SERIES X (IE
C     WITH THOSE = 1.E35 OMITTED) , AND THE AVERAGE AND STANDARD DEV-
C     IATION OF X .
C   --RT IS THE RMS OF THE RESIDUALS OF THE FIT CALCULATED PREVIOUS TO
C     THE PREDICTIONS USING THE MULTIPLE CORRELATION TECHNIQUE.
C   --RA IS THE SAME AS RT ONLY CALCULATED DIRECTLY FROM THE DIFFERENCES
C     BETWEEN DATA AND PREDICTIONS. IF RA AND RT ARE NOT PRETTY CLOSE
C     THEN THERE IS A BUG IN THIS PROGRAM OR ROUNDING ERRORS ARE GETTING
C     SERIOUS OR THE FIT IS ALMOST PERFECT.
C   --XP(I),I=1,..NIN ARE THE PREDICTED X VALUES.
C     XP(I) = C(K)*COS(2PI*F(K)*T) + S(K)*SIN(2PI*F(K)*T)  SUMMED OVER M
C     T=I-NIN/2 (IE THE TIME ORIG IS AT THE CENTER POINT OF SERIES X .)
C
C  NOTES
C  ------
C   1) AVX IS SUBTRACTED FROM X DURING THE ANALYSIS IF F(1) = 0.
C   2) ALL FREQUENCIES SHOULD BE LESS THAN  HALF A CYCLE PER TIME
C     INCREMENT . FOR GOOD RESOLUTION IT IS SUFFICIENT THAT ADJACENT
C     FREQUENCIES DIFFER BY ONE CYCLE OR MORE OVER THE DURATION OF THE
C     ANALYSIS IF THE GAPS ARE SMALL .
C   3) SUBROUTUNE LSQSLV IS REQUIRED TO SOLVE THE EQUATIONS.
C   4) ARRAY A MUST BE DIMENSIONED AT LEAST (2*M+1)*M , RHS AT LEAST 2*M
C      AND THE OTHER ARRAYS AT LEAST M.
C
C     THIS ROUTINE IS PART OF THE TIDAL STREAMS ANALYSIS PROGRAM FOR
C     DR G GODIN    OCEANOGRAPHIC RESEARCH/EMR    JULY/70
C
      REAL*8 AVX,SSX,CWTK,CWTKK,SWTK,CK,SK,CWK,SWK,XL,XU,XPDT,RAA,CW1,SW
     11,CSUM,SSUM
      DIMENSION F(100),ERS(100),ERC(100),C(100),S(100)
      DIMENSION RHS(200),CW(100),SW(100),CW1(100),SW1(100)
      DIMENSION X(18000),XP(18000),A(15000)
      DIMENSION AC(7500),AS(7500),RHSC(100),RHSS(100)
      EQUIVALENCE (AC(1),A(1)),(AS(1),A(7501)),(RHS(1),RHSC(1)),(RHS(101
     1),RHSS(1))
C
C***********************************************************************
C*  INITIALIZE
C
      PI=3.141592653589793
      PI2 = 2.*PI
      BIG=.9E35
      LP = 6
      IMID = (NIN+1)/2
      N =  IMID*2-1
      NH =N/2
      NH1=NH+1
C
C***********************************************************************
C*  NX IS THE NUMBER OF OBSERVATIONS (NOT INCLUDING GAPS) IN THE
C*     DESIRED ANALYSIS PERIOD.
C*  AVX=AVREM IS THE AVERAGE OF THESE OBSERVATIONS.
C*  SDX IS THE STANDARD DEVIATION ESTIMATE.
C
      NX=0
      AVX=0.D0
      DO 25 I=1,N
      IF(X(I).GE.BIG) GO TO 25
      NX=NX+1
      AVX=AVX+X(I)
25    CONTINUE
      AVX=AVX/NX
      SSX = 0.D0
      DO 27 I=1,N
      IF(X(I).LT.BIG) SSX=SSX+(X(I)-AVX)**2
27    CONTINUE
      SDX=SSX/(NX-1)
      SDX=SQRT(SDX)
C
C***********************************************************************
C*  SSX IS THE ORIGINAL SUM OF SQUARES OF THE HOURLY HEIGHTS.
C*  NDF IS THE NUMBER OF DEGREES OF FREEDOM.
C
      NDF=NX-2*M+1
      IF(NDF.GE.0) GO TO  40
      WRITE (LP,30)
30    FORMAT(/' SUBROUTINE SCFIT2 , NDF NEGATIVE , STOP' /)
      STOP
C
C***********************************************************************
C*  THE ZERO FREQUENCY MUST BE THE FIRST ONE IN THE LIST.
C
40    DO  50 K=1,M
      CW(K) = COS(PI2*F(K))
50    SW(K) = SIN(PI2*F(K))
      M2=2*M
      M2M2=(M2*M2+M2)/2
      M1M1=(3*M*M+M)/2+1
      MM=(M*M+M)/2
      IF(IND.EQ.2) GO TO 500
C
C***********************************************************************
C*  ACCUMULATE RIGHT SIDES OF NORMAL EQUATIONS FOR C AND S.
C*  THESE TAKE THE FORM OF SUM(I) Y(I)*COS(2PI*SIGMA(J)*T(I))  AND
C*  SUM(I) Y(I)*SIN(2PI*SIGMA(J)*T(I)) FOR J=1,M CONSTITUENTS AND
C*  T(I)=-NH,-NH+1,...,0,...NH.
C
C
      DO 140 K=2,M
      CWK = CW(K)
      SWK = SW(K)
      CWTK =1.D0
      SWTK =0.D0
      CK=0.D0
      IF(X(IMID).LT.BIG) CK=X(IMID)-AVX
      SK = 0.D0
      DO 120  I=1,NH
C
C***********************************************************************
C*  USING THE IDENTITIES FOR COS(T+DT) AND SIN(T+DT)
C
      CWTKK = CWTK*CWK - SWTK*SWK
      SWTK  = CWTK*SWK + SWTK*CWK
      CWTK=CWTKK
      IL =IMID-I
      IU= IMID+I
      XL=0.D0
      XU=0.D0
      IF(X(IL).LT.BIG) XL=X(IL)-AVX
      IF(X(IU).LT.BIG) XU=X(IU)-AVX
C
C***********************************************************************
C*  USING COS(DT)=COS(-DT) AND SIN(DT)=-SIN(-DT)
C
      CK = CK + (XU+XL)*CWTK
120   SK = SK + (XU-XL)*SWTK
      C(K)=CK
      S(K)=SK
140   CONTINUE
C
C***********************************************************************
C*  BECAUSE THE AVERAGE VALUE HAS BEEN SUBTRACTED FROM ALL THE OBSERVA-
C*  TIONS, THE FIRST ELEMENT IN THE RIGHT HAND SIDE IS 0.
C
      C(1)=0.
      S(1)=0.
C
C***********************************************************************
C*  IF THERE ARE NO GAPS IN THE DATA THEN THE RESULTANT LEAST SQUARES
C*  MATRIX HAS ZEROS IN THE UPPER RIGHT AND LOWER LEFT PARTITIONS. IF
C*  THE NEW MATRIX EQUATIONS OBTAINED FROM THESE NON-ZERO PARTITIONS
C*  ARE SOLVED SEPARATELY, THIS MAKES FOR AN APPROXIMATE FOUR FACTOR
C*  TIME SAVING IN THE CHOLESKY FACTORIZATION.
C
      IF(N.EQ.NX) GO TO 600
C
C***********************************************************************
C*  GENERATE THE MATRIX BY SUMMING THE CONTRIBUTIONS FROM EACH OF THE
C*  CONTINUOUS BLOCKS OF DATA.
C
      DO 160 JK=1,M2M2
160   A(JK)=0.0
C
C***********************************************************************
C*  IA AND IB ARE RESPECTIVELY THE FIRST AND LAST READINGS IN A
C*  CONTINUOUS BLOCK OF DATA.
C
      IA=-NH-1
180   IA=IA+1
      IF(IA.GT.NH) GO TO 300
      IIA=IA+IMID
      IF(X(IIA).GE.BIG) GO TO 180
      I=IA
185   I=I+1
      IF(I.GT.NH) GO TO 190
      II=I+IMID
      IF(X(II).LT.BIG) GO TO 185
190   IB=I-1
      AB=IA+IB
      BA1=IB-IA+1
C
C***********************************************************************
C*  TRIGONOMETRIC IDENTITIES AVOID THE SUMMATIONS REQUIRED IN
C*  CALCULATING THE MATRIX ELEMENTS.
C*  ONLY THE LOWER TRIANGLE (INCLUDING DIAGONAL) OF THE MATRIX NEED BE
C*  GENERATED.
C
      DO 260 J=1,M
      WJ=PI*F(J)
      SIND=BA1
      SINS=BA1
      IF(J.GT.1) SINS=SIN(2.*BA1*WJ)/SIN(2.*WJ)
240   DO 255 K=J,M
      JK=M2*(J-1)+K-(J*J-J)/2
      JKM=JK+M
      JM=J+M
      KJM=M2*(K-1)+JM-(K*K-K)/2
      JMKM=M2*(JM-1)+K+M-(JM*JM-JM)/2
      WK=PI*F(K)
      WD=WJ-WK
      WS=WJ+WK
      IF(J.EQ.K) GO TO 250
      SIND=SIN(BA1*WD)/SIN(WD)
      SINS=SIN(BA1*WS)/SIN(WS)
250   TD=COS(AB*WD)*SIND
      TS=COS(AB*WS)*SINS
      A(JK)=A(JK)+.5*(TD+TS)
      A(JMKM)=A(JMKM)+.5*(TD-TS)
      TD=SIN(AB*WD)*SIND
      TS=SIN(AB*WS)*SINS
      IF(J.EQ.K) GO TO 255
      A(JKM)=A(JKM)+.5*(-TD+TS)
255   A(KJM)=A(KJM)+.5*(TD+TS)
260   CONTINUE
      IA=IB
      GO TO 180
C
C***********************************************************************
C*  S(1) IS FORCED TO ZERO BY SETTING THIS MATRIX ELEMENT TO LARGE VALUE
C
  300 A(M1M1)=NX
C
C***********************************************************************
C*  SOLVE THE EQUATIONS FOR C AND S .
C
      DO 370 K=1,M
      RHS(K)=C(K)
      MPK=M+K
370   RHS(MPK)=S(K)
C
C***********************************************************************
C*  SINCE THE TWO DIMENSIONAL MATRIX DUE TO THE LEAST SQUARES FIT IS
C*  POSITIVE DEFINITE SYMMETRIC, IT CAN BE DECOMPOSED INTO THE FORM
C*  G*G(TRANSPOSE), WHERE G IS A LOWER TRIANGULAR MATRIX. SUBROUTINE
C*  TRIANG FINDS THIS G AND SOLUTN SOLVES THE RESULTING LINEAR
C*  EQUATIONS BY FORWARD AND BACKWARD SUBSTITUTION.
C
      CALL TRIANG(A,RHS,G,M2)
      IF(G.GT.0.) GO TO 371
      WRITE(LP,372) g
  372 FORMAT(' THE LEAST SQUARES MATRIX IS ILL-CONDITIONED AND COULD NOT
     1 BE TRIANGULARIZED: g=',f10.5)
      STOP
  371 CONTINUE
      GG=1.005
      CALL SOLUTN(A,RHS,GG,M2)
      XPDT=0.D0
      DO 380 K=1,M
      MPK=M+K
      XPDT=XPDT+RHS(K)*C(K)+RHS(MPK)*S(K)
      C(K)=RHS(K)
380   S(K)=RHS(MPK)
C
C***********************************************************************
C*  THE EXPECTED ERRORS ARE CALCULATED FROM THE INVERSE MATRIX DIAGONAL
C*  ELEMENTS.
C
      DO 420 K=1,M2
      DO 400 KK=1,M2
400   RHS(KK)=0.
      RHS(K)=1.0
      GG=K+.005
      CALL SOLUTN(A,RHS,GG,M2)
      IF(K.LE.M) GO TO 405
      KMM=K-M
      ERS(KMM)=SQRT(RHS(K))
      GO TO 406
405   ERC(K)=SQRT(RHS(K))
406   CONTINUE
420   CONTINUE
C
C***********************************************************************
C*  GET THEORETICAL RESIDUAL RT AND EXPECTED ERRORS ERC,ERS OF C,S .
C*  XPDT IS THE SUM OF SQUARES DUE TO REGRESSION.
C*  RT IS THE ROOT MEAN SQUARE RESIDUAL ERROR.
C*  SSX-XPDT IS THE RESIDUAL ERROR SUM OF SQUARES.
  515 RAD=SSX-XPDT
      RAD=ABS(RAD)/NDF
      RT=SQRT(RAD)
      DO 450 K=1,M
      ERC(K) =  ERC(K)*RT
450   ERS(K) =  ERS(K)*RT
      C(1)=C(1)+AVX
      AVREM=AVX
C
C***********************************************************************
C*    CALCULATE PREDICTIONS XP(1...N) AND ACTUAL RESIDUAL RA.
C
  500 IF(IND.EQ.0) RETURN
      XP(IMID)=0.
      DO 510 K=1,M
      CW1(K)=1.D0
      SW1(K)=0.D0
  510 XP(IMID)=XP(IMID)+C(K)
      IMAX=NH
      IF(NIN.GT.N) IMAX=NH1
      DO 550 I=1,IMAX
      IL=IMID-I
      IU=IMID+I
      CSUM=0.D0
      SSUM=0.D0
      DO 530 K=1,M
      CWTK=CW1(K)*CW(K)-SW1(K)*SW(K)
      SW1(K)=CW1(K)*SW(K)+SW1(K)*CW(K)
      CW1(K)=CWTK
      CSUM=CSUM+C(K)*CW1(K)
  530 SSUM=SSUM+S(K)*SW1(K)
      IF(I.EQ.NH1) GO TO 531
      XP(IL)=CSUM-SSUM
  531 XP(IU)=CSUM+SSUM
  550 CONTINUE
      RAA=0.D0
      DO 570 I=1,N
      IF(X(I).LT.BIG) RAA=RAA+(X(I)-XP(I))**2
  570 CONTINUE
      RA=RAA
      RA=SQRT(RA/NDF)
      RETURN
C
C***********************************************************************
C*  WHEN THERE ARE NO GAPS IN THE RECORD, THE C AND S COEFFICIENT
C*  MATRICES ARE SOLVED SEPARATELY.
C
  600 BA1=2*NH+1
      DO 601 J=1,MM
      AC(J)=0.
  601 AS(J)=0.
      DO 660 J=1,M
      WJ=PI*F(J)
      T1=BA1
      T2=BA1
      IF(J.GT.1) T2=SIN(2.*BA1*WJ)/SIN(2.*WJ)
      JK=M*(J-1)-(J*J-J)/2+J
      DO 655 K=J,M
      IF(J.EQ.K) GO TO 650
      WK=PI*F(K)
      T1=SIN(BA1*(WJ-WK))/SIN(WJ-WK)
      T2=SIN(BA1*(WJ+WK))/SIN(WJ+WK)
  650 AC(JK)=(T1+T2)*0.5
      AS(JK)=(T1-T2)*0.5
  655 JK=JK+1
  660 CONTINUE
      AS(1)=BA1
      DO 670 I=1,M
      RHSC(I)=C(I)
  670 RHSS(I)=S(I)
      CALL TRIANG(AC,RHSC,GC,M)
      IF(GC.GT.0.) GO TO 609
      WRITE(LP,372)
      STOP
  609 CALL TRIANG(AS,RHSS,GS,M)
      IF(GS.GT.0.) GO TO 611
      WRITE(LP,372)
      STOP
  611 G=GS*GC
      GGS=1.005
      GGC=1.005
      CALL SOLUTN(AC,RHSC,GGC,M)
      CALL SOLUTN(AS,RHSS,GGS,M)
      XPDT=0.D0
      DO 612 K=1,M
      XPDT=XPDT+RHSC(K)*C(K)+RHSS(K)*S(K)
      C(K)=RHSC(K)
  612 S(K)=RHSS(K)
C
C***********************************************************************
C*  THE EXPECTED ERRORS ARE CALCULATED FROM THE INVERSE MATRIX DIAGONAL
C*  ELEMENTS.
C
      DO 613 K=1,M
      DO 614 KK=1,M
      RHSS(KK)=0.
  614 RHSC(KK)=0.
      RHSC(K)=1.
      GGC=K+.005
      CALL SOLUTN(AC,RHSC,GGC,M)
      ERC(K)=SQRT(RHSC(K))
      RHSS(K)=1.
      GGS=K+.005
      CALL SOLUTN(AS,RHSS,GGS,M)
      ERS(K)=SQRT(RHSS(K))
  613 CONTINUE
      GO TO 515
      END
      SUBROUTINE CHLSKY(A,F,G,N)
C
C***********************************************************************
C*    ROUTINE TO SOLVE SYMMETRIC POSITIVE DEFINITE MATRICES FOUND IN
C*    LINEAR LEAST SQUARES PROBLEMS.  THE CHOLESKY SQUARE METHOD (ALSO
C*    ATTRIBUTED TO BANACHIEWICZ) IS USED.  SEE LEAST SQUARES PROGRAM-
C*    MING FOR BAND MATRICES BY B. EVANS. COMPUTATIONAL METHODS FOR
C*    LINEAR ALGEBRA BY FADDEEV AND FADDEEVA PAGE 145. ADVANCES IN
C*    COMPUTERS VOL 2 PAGE 57.  COMPUTER SOLUTION OF LINEAR ALGEBRAIC
C*    SYSTEMS BY FORSYTHE AND MOLER PAGE 114.
C*
C*    DIRECTIONS...
C*    1... CALL TRIANG WITH THE UPPER TRIANGLE OF THE MATRIX STORED
C*    BY ROWS IN THE ONE DIMENSIONAL ARRAR A.  THE PRICE OF THIS
C*    STORAGE SAVING IS EXTRA PROCESSING TIME DUE TO A COMPLEX
C*    SUBSCRIPTING. IN TRIANG, A IS FACTORIZED AND THE NEW MATRIX
C*    REPLACES A.  THE MATRIX CONDITION IS RETURNED IN G.  IF (G.LE.0),
C*    THEN G IS SET TO -I (ROW NUMBER) AND AN IMMEDIATE RETURN IS MADE.
C*    2...CALL SOLUTN WITH THE RIGHT HAND SIDE ARRAY IN F. THE SOLUTION
C*    IS RETURNED IN F.
C
C*    DEC/76 ... INDEXING SIMPLIFIED TO IMPROVE SPEED.
C*    IF F(I)=0 FOR ALL I EXCEPT F(IENTRY)=1.0, THEN SETTING G TO
C*    IENTRY CAUSES THE PROGRAM TO CALCULATE ONLY THE PARTIAL SOLUTION
C*    F(IENTRY)...F(N). THIS IS USEFUL FOR GETTING THE
C*    DIAGONAL ELEMENTS OF THE INVERSE MATRIX WHICH ARE RELATED TO THE
C*    EXPECTED ERRORS IN THE REGRESSION COEFFICIENTS AND ALLOWS A SPEED
C*    IMPROVEMENT OF ABOUT 3X. FOR OTHER TYPES OF RHS THE FULL SOLUTION
C*    IS FOUND. TO CANCEL THIS FEATURE SET IENTRY=1 FOR ALL TIME.
C
C*    TIMING FOR...TRIANGULARIZE + SOLVE ONE RHS + GET INVERSE MATRIX
C*    DIAGONAL ELEMENTS (N=124, CYBER/74)
C*       OLD TIME = 3.0+.09+12.0=15.9 SEC.
C*       NEW TIME = 2.0+.06+ 3.5= 5.56 SEC.=37 PERCENT OF OLD.
C
      DIMENSION A(15000),F(200)
C
C***********************************************************************
C*    CHOLESKY FACTORIZATION OF THE MATRIX A.
      ENTRY TRIANG(A,F,G,N)
      NP1=N+1
10    IF(A(1))20,20,30
20    G=-1.
      RETURN
30    A(1)= SQRT(A(1))
      DO 40 J=2,N
40    A(J)=A(J)/A(1)
      G=1.
      II=1
50    DO 100 I=2,N
      IP1=I+1
      IM1=I-1
      II=II+N+2-I
      AII=A(II)
      LI=I-N
      DO 60 L=1,IM1
      LI=LI+NP1-L
60    AII=AII-A(LI)*A(LI)
      IF(AII)65,65,70
65    G=-I
      RETURN
70    G=G*AII/A(II)
      A(II)= SQRT(AII)
      IF(I-N)75,100,75
75    DO 90 J=IP1,N
      IJ=II+J-I
      AIJ=A(IJ)
      JMI=J-I
      LI=I-N
      DO 80 L=1,IM1
      LI=LI+NP1-L
      LJ=LI+JMI
80    AIJ=AIJ-A(LI)*A(LJ)
90    A(IJ)=AIJ/A(II)
100   CONTINUE
      G= SQRT(G)
      RETURN
C
C***********************************************************************
C*    SOLUTION OF THE TRIANGULARIZED MATRIX EQUATION
C*    G NOW DENOTES WHETHER OR NOT AN EXPECTED ERROR CALCULATION IS
C*    DESIRED; THAT IS, IF THE RIGHT HAND SIDE OF THE MATRIX EQUATION
C*    IS A VECTOR WITH VALUE 1 IN ONLY ONE LOCATION AND ZEROES
C*    EVERYWHERE ELSE.  IN THESE CASES, THE FORWARD AND BACKWARD
C*    SUBSTITUTION METHODS CAN BE ABBREVIATED AND RESULT IN AN APPROX.
C*    3 FACTOR TIME SAVING.  A G VALUE EQUAL TO K INDICATES SUCH A
C*    CASE WITH THE 1 IN THE K-TH POSITION.  A G VALUE EQUAL TO 1
C*    INDICATES THAT A STANDARD MATRIX SOLUTION METHOD IS REQUIRED.
      ENTRY SOLUTN(A,F,G,N)
C
C***********************************************************************
C     FORWARD SOLUTION OF RIGHT HAND SIDE
C
      IENTRY=INT(G)
      NP1=N+1
      DO 220 I=IENTRY,N
      IM1=I-1
      FI=F(I)
      LI=((N+N-IENTRY)*(IENTRY-1))/2+I
      IF(I.EQ.IENTRY) GO TO 220
      DO 210 L=IENTRY,IM1
      FI=FI-A(LI)*F(L)
  210 LI=LI+N-L
220   F(I)=FI/A(LI)
C
C***********************************************************************
C*    BACKWARD SUBSTITUTION FOR FINAL SOLUTION
C
230   NN=(N*(N+1))/2
      F(N)=F(N)/A(NN)
      IF(IENTRY.EQ.N) RETURN
      II=NN
      IENTB=N+1-IENTRY
      DO 260 IB=2,IENTB
      I=N+1-IB
      II=II+I-NP1
      IP1=I+1
      FI=F(I)
      III=II-I
      DO 250 L=IP1,N
      IL=III+L
250   FI=FI-A(IL)*F(L)
260   F(I)=FI/A(II)
      RETURN
      END
C*********************************************************************
C*********************************************************************
      SUBROUTINE GDAY(IDD,IMM,IYear,KD)
C!
C!  GIVEN DAY,MONTH,(EACH 2 DIGITS) and year (four digits), GDAY RETURNS
C!  THE DAY#, KD BASED ON THE GREGORIAN CALENDAR.
C!  THE GREGORIAN CALENDAR, CURRENTLY 'UNIVERSALLY' IN USE WAS
C!  INITIATED IN EUROPE IN THE SIXTEENTH CENTURY. NOTE THAT GDAY
C!  IS VALID ONLY FOR GREGORIAN CALENDAR DATES.
C
C   KD=1 CORRESPONDS TO JANUARY 1, 0000
C	
c 	Note that the Gregorian reform of the Julian calendar 
c	omitted 10 days in 1582 in order to restore the date
c	of the vernal equinox to March 21 (the day after
c	Oct 4, 1582 became Oct 15, 1582), and revised the leap 
c	year rule so that centurial years not divisible by 400
c	were not leap years.
c
C   THIS ROUTINE WAS WRITTEN BY EUGENE NEUFELD, AT IOS, IN JUNE 1990.
C
      INTEGER NDP(13)
      INTEGER NDM(12)
	
      DATA NDP/0,31,59,90,120,151,181,212,243,273,304,334,365/
      DATA NDM/31,28,31,30,31,30,31,31,30,31,30,31/
C!
	lp=6
c make iyy and icc variables
        icc=iyear/100
        iyy=iyear-icc*100

C!  TEST FOR INVALID INPUT:
      IF(ICC.LT.0)THEN
	 WRITE(LP,5000)ICC
	 STOP
      ENDIF
      IF(IYY.LT.0.OR.IYY.GT.99)THEN
	 WRITE(LP,5010)IYY
	 STOP
      ENDIF
      IF(IMM.LE.0.OR.IMM.GT.12)THEN
	 WRITE(LP,5020)IMM
	 STOP
      ENDIF
      IF(IDD.LE.0)THEN
	 WRITE(LP,5030)IDD
	 STOP
      ENDIF
      IF(IMM.NE.2.AND.IDD.GT.NDM(IMM))THEN
	 WRITE(LP,5030)IDD
	 STOP
      ENDIF
      IF(IMM.EQ.2.AND.IDD.GT.29)THEN
	 WRITE(LP,5030)IDD
	 STOP
      ENDIF
      IF(IMM.EQ.2.AND.IDD.GT.28.AND.((IYY/4)*4-IYY.NE.0.OR.(IYY.EQ.0.AND
     .    .(ICC/4)*4-ICC.NE.0)))THEN
	 WRITE(LP,5030)IDD
	 STOP
      ENDIF
5000  FORMAT(' INPUT ERROR. ICC = ',I7)
5010  FORMAT(' INPUT ERROR. IYY = ',I7)
5020  FORMAT(' INPUT ERROR. IMM = ',I7)
5030  FORMAT(' INPUT ERROR. IDD = ',I7)
C!
C!  CALCULATE DAY# OF LAST DAY OF LAST CENTURY:
      KD = ICC*36524 + (ICC+3)/4
C!
C!  CALCULATE DAY# OF LAST DAY OF LAST YEAR:
      KD = KD + IYY*365 + (IYY+3)/4
C!
C!  ADJUST FOR CENTURY RULE:
C!  (VIZ. NO LEAP-YEARS ON CENTURYS EXCEPT WHEN THE 2-DIGIT
C!  CENTURY IS DIVISIBLE BY 4.)
      IF(IYY.GT.0.AND.(ICC-(ICC/4)*4).NE.0) KD=KD-1
C!  KD NOW TRULY REPRESENTS THE DAY# OF THE LAST DAY OF LAST YEAR.
C!
C!  CALCULATE DAY# OF LAST DAY OF LAST MONTH:
      KD = KD + NDP(IMM)
C!
C!  ADJUST FOR LEAP YEARS:
      IF(IMM.GT.2.AND.((IYY/4)*4-IYY).EQ.0.AND.((IYY.NE.0).OR.
     .   (((ICC/4)*4-ICC).EQ.0)))   KD=KD+1
C!  KD NOW TRULY REPRESENTS THE DAY# OF THE LAST DAY OF THE LAST
C!  MONTH.
C!
C!  CALCULATE THE CURRENT DAY#:
      KD = KD + IDD
      RETURN
C!
C!
      ENTRY DMY(IDD,IMM,IYear,KD)
C!
C!  GIVEN THE (GREGORIAN) DAY#, KD, AS CALCULATED ABOVE IN THIS ROUTINE,
C!  ENTRY DMY RETURNS THE (GREGORIAN) DAY, MONTH, YEAR AND CENTURY.
C!
C!  TEST FOR VALID INPUT:
      IF(KD.LE.0) WRITE(LP,5040)KD
5040  FORMAT(' KD = ',I7,'  INVALID INPUT. DMY STOP.')
C!
C!  SAVE KD
      KKD=KD
C!  CALCULATE ICC AND SUBTRACT THE NUMBER OF DAYS REPRESENTED BY ICC
C!  FROM KKD
C!  JFH IS THE NUMBER OF 400 YEAR INTERVALS UP TO KKD
C!  JCC IS THE NUMBER OF ADDITIONAL CENTURIES UP TO KKD
      JFH = KKD/146097
      KKD = KKD - JFH*146097
      IF(KKD.LT.36525)THEN
	 JCC = 0
      ELSE
	 KKD = KKD - 36525
	 JCC = 1 + KKD/36524
	 KKD = KKD - (JCC-1)*36524
      END IF
      ICC = 4*JFH + JCC
      IF(KKD.EQ.0)THEN
	 ICC = ICC-1
	 IYY = 99
	 IMM = 12
	 IDD = 31
c	 RETURN
	go to 110
      ENDIF
C!
C!  CALCULATE IYY. JFY IS THE NUMBER OF FOUR YEAR INTERVALS IN THE
C!  CURRENT CENTURY. THE FIRST FOUR YEAR INTERVAL IS SHORT (1460 DAYS
C!  RATHER THAN 1461)IF THE CURRENT CENTURY IS NOT DIVISIBLE BY 4, AND
C!  IN THIS CASE JCC.NE.0 AS CALCULATED ABOVE.
C!
C!  CALCULATE JFY:
      JFY = 0
      IF(JCC.EQ.0)GOTO 10
      IF(KKD.LT.1460)GOTO 10
      JFY = 1
      KKD = KKD - 1460
10    KK = KKD/1461
      JFY = JFY + KK
      KKD = KKD - KK*1461
C!
C!  CALCULATE JYY, THE REMAINING YEARS OF THE CURRENT CENTURY UP TO THE
C!  CURRENT DAY:
      JYY = 0
C!  THE NEXT YEAR IS NOT A LEAP YEAR IF JFY=0 AND JCC.NE.0.
      IF(JFY.EQ.0.AND.JCC.NE.0)GOTO 20
      IF(KKD.LT.366)GOTO 30
      JYY = 1
      KKD = KKD - 366
20    JYYY = KKD/365
      JYY = JYY + JYYY
      KKD = KKD - JYYY*365
30    IYY = 4*JFY + JYY
      IF(KKD.EQ.0) THEN
	 IYY=IYY-1
	 IMM=12
	 IDD=31
c	 RETURN
	go to 110
      END IF
C!
C!  SET L=1 IF WE HAVE A LEAP YEAR.
      L=0
      IF(IYY-(IYY/4)*4.NE.0)GOTO 40
      IF(IYY.EQ.0.AND.(ICC-(ICC/4)*4).NE.0)GOTO 40
      L=1
C!
C!  CALCULATE IMM AND IDD
40    IF(KKD.GT.31) GOTO 50
      IMM=1
      IDD=KKD
c      RETURN
       go to 110
C!
50    IF(KKD.GT.59)GOTO 60
      IMM = 2
      IDD = KKD-31
c      RETURN
	go to 110
C!
60    IF(KKD.GT.60)GOTO 70
      IF(L.EQ.0)GOTO 70
      IMM = 2
      IDD = 29
c      RETURN
	go to 110
C!
70    IF(L.EQ.1) KKD=KKD-1
      DO 80 I=4,13
	 IF(KKD.GT.NDP(I))GOTO 80
	 IMM = I-1
	 IDD = KKD - NDP(I-1)
c	 RETURN
	go to 110
C!
80    CONTINUE

 110 	iyear=icc*100+iyy
	return

90    WRITE(LP,5050)
5050  FORMAT(' ERROR IN DMY.')
      STOP
      END

	Subroutine Up_date(kd,ssec)
C 
C this subroutine updates the current gregorian day number kd
C and resets the time, ssec, accordingly
C it inherently assumes that the variable is updated every day!

      integer kd
      real ssec
	
      kd=kd+aint(ssec/86400.0)
      ssec=MOD(ssec,86400.0)
 
      return
      end
C*********************************************************************
C*********************************************************************
      SUBROUTINE GMT0_GDAY(IYEAR,YDAYUTC0,KD,SECKD)
C-----------------------------------------------------------------------
      CALL UTC0_GDAY(IYEAR,YDAYUTC0,KD,SECKD)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE GDAY_GMT0(KD,SECKD,IYEAR,YDAYUTC0)
C-----------------------------------------------------------------------
      CALL GDAY_UTC0(KD,SECKD,IYEAR,YDAYUTC0)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE UTC0_GDAY(IYEAR,YDAYUTC0,KD,SECKD)
C-----------------------------------------------------------------------
      CALL GDAY(01,01,IYEAR,KDNEWYEAR)
      KD=KDNEWYEAR+INT(AINT(YDAYUTC0))
      SECKD=24.0*3600.0*(YDAYUTC0-AINT(YDAYUTC0))
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE GDAY_UTC0(KD,SECKD,IYEAR,YDAYUTC0)
C-----------------------------------------------------------------------
      CALL DMY(ID,IM,IYEAR,KD)
      CALL GDAY(01,01,IYEAR,KDNEWYEAR)
      YDAYUTC0=KD-KDNEWYEAR+SECKD/3600.0/24.0
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE VUFUTC0(KONK,DEGLAT,IYEAR,YDUTC0,F,VU,FREQ)
C-----------------------------------------------------------------------
      CHARACTER*5 KONK,CDUM
c
c Determine tidal parameters at beginning of the day
c
      CALL UTC0_GDAY(IYEAR,YDUTC0,KD,SECKD)
      KH0=KD*24
      CALL OPNVUF(KH0,CDUM,DEGLAT,RDUM,RDUM,RDUM)
      CALL VUF(KH0,KONK,DEGLAT,F,VU0,SIG)
c
c Calculate tidal frequency in radians per second
c Convert VU to radians and shift to exact time sent to routine
c
      FREQ=2.0*ACOS(-1.0)*SIG/3600.0
      VU=2.0*ACOS(-1.0)*VU0+FREQ*SECKD
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE VUFGDAY(KONK,DEGLAT,KD,SECKD,F,VU,FREQ)
C-----------------------------------------------------------------------
      CHARACTER*5 KONK,CDUM
c
c Determine tidal parameters at beginning of the day
c
      KH0=KD*24
      CALL OPNVUF(KH0,CDUM,DEGLAT,RDUM,RDUM,RDUM)
      CALL VUF(KH0,KONK,DEGLAT,F,VU0,SIG)
c
c Calculate tidal frequency in radians per second
c Convert VU to radians and shift to exact time sent to routine
c
      FREQ=2.0*ACOS(-1.0)*SIG/3600.0
      VU=2.0*ACOS(-1.0)*VU0+FREQ*SECKD
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE DECOMPCEN(NTSDIM,NTS,TS,IHH0,IDD0,IMM0,IYEAR0,NHS,
     &DEGLAT,M,KON,F,VU,SIG,AMP,PHASE)
C-----------------------------------------------------------------------
C 
C index range:  I=1,NTS, J=1,NHS, K=1,M
C
C inputs from calling routine:
C  NTSDIM - dimensioning parameter for NTS
C  NTS - number of time series
C  TS(I,J) - time series array
C  IHH0,IDD0,IMM0,IYEAR0 - Starting time
C  NHS - number of hourly samples (reduced by one within if sent number
C        is even)
C  DEGLAT - degrees latitude
C  M - number of frequencies
C  KON(K) - names of frequencies
C
C Output to calling routine:
C  AMP(I,K) - individual constituent amplitudes
C  PHASE(I,K) -  individual constituent phases
C-----------------------------------------------------------------------
      PARAMETER(MDIM=100)
C
C Global Assignments
      REAL TS(NTSDIM,*)
      CHARACTER*5 KON(*)
      REAL AMP(NTSDIM,*),PHASE(NTSDIM,*)
C
C Local Assignments
      REAL F(MDIM),VU(MDIM)
      REAL SIG(100),C(100),S(100),ERC(100),ERS(100),Z(18000),DA(18000)
      CHARACTER*5 CDUM
C
C Create degree function
      DEGREE(CYC)=(CYC-IFIX(CYC)-SIGN(.5,CYC)+.5)*360.
C
C Check local dimensioning parameters
C  For F and VU
      NFLAG=0
      IF(M.GT.MDIM)THEN
      WRITE(*,*)'Increase MDIM (SUBROUTINE DECOMPCEN) to exceed',M
      NFLAG=1
      ENDIF
C  For arrays passed to SCFIT2 (where they are hard-wired!).
      IF(M.GT.100)THEN
      WRITE(*,*)'Hard-wired array sizes in SCFIT2 require that there be
     &no more than 100 constituents.'
      NFLAG=1
      ENDIF
      IF(NHS.GT.18000)THEN
      WRITE(*,*)'Hard-wired array sizes in SCFIT2 require that the numbe
     &r of hourly samples not exceed 18000.'
      NFLAG=1
      ENDIF
C  Return if NFLAG.EQ.1
      IF(NFLAG.EQ.1)THEN
      WRITE(*,*)'Return from SUBROUTINE DECOMPCEN without performing dec
     &omposition.'
      RETURN
      ENDIF
C
C Set constants and truncate the number of samples if it is not odd
      PI=ACOS(-1.0)
      TWOPI=2.*PI
      IF(MOD(NHS,2).EQ.0)NHS=NHS-1
C
C Determine tidal constituent parameters at the middle of the hourly
C   sample window as the values returned by SCFIT2 are in terms of
C   that time (CDUM and D* are dummy assignments)
      CALL GDAY(IDD0,IMM0,IYEAR0,KD0)
      KMID=KD0*24+IHH0+(NHS-1)/2
      CALL OPNVUF(KMID,CDUM,DEGLAT,D1,D2,D3)
      DO K=1,M
         CALL VUF(IDUM,KON(K),DUM,F(K),VU(K),SIG(K))
      ENDDO
C
C Perform the decomposition
      DO I=1,NTS
C   Set 1-D array for this time-series of data 
         DO J=1,NHS
            Z(J)=TS(I,J)
         ENDDO
C   Find the least squares fit (D* and ND* are dummy assignments)
         CALL SCFIT2(Z,NHS,SIG,M,0,C,S,ERC,ERS,D1,ND2,D3,D4,D5,D6,DA)
C   Post process results:
C     change results to polar form
C     correct for F and VU
C     save results in AMP and PHASE arrays
         DO K=1,M
            AK=SQRT(C(K)*C(K)+S(K)*S(K))
            EPSK=ATAN2(S(K),C(K))/TWOPI
            AMP(I,K)=AK/F(K)
            PHASE(I,K)=DEGREE(EPSK+VU(K))
         ENDDO
      ENDDO
      RETURN
      END
C***********************************************************************
C***********************************************************************
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine radians(omegat, kd, kdprt, seckd, seckdprt, fprt, kp)
C
C Subr. radians computes omega*(t-t0) for perturbation #kp
C  omegat                  : result
C (kd, seckd)              : time of evaluation; gregorian standard
C (kdprt(kp), seckdprt(kp)): t0 for this perturbation; gregorian
C                              standard
C  fprt(kp)                : frequency, radians/s
C
C drl, 6 april 99
c  It was found that this calculation is sensitive to roundoff error.,
c  The error is worse on sgi than ibm machines.
C  There are 2 items which make a difference:
C    a) avoiding buildup of large values of t-t0; this occurs in the day
C         counter.  this part of omegat is calculated separately and
C         reduced to its modulus(2*pi).
C    b) using precise evaluation of pi
C
      integer kdprt(*)
      real seckdprt(*), fprt(*)
      double precision dtwopi, dradkd
      dtwopi  = 2.d0*dacos(-1.d0)
      dradkd  = (kd-kdprt(kp))*(fprt(kp)*8.64d4)
      dradkd  = dmod(dradkd,dtwopi)
      radsec  = (seckd-seckdprt(kp))*fprt(kp)
      omegat  = dradkd + radsec
      return
      end
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE VUF_NML(kd0,konk,xlat,fk,vuk,freqk)
      integer kd0 
      CHARACTER*5 konk
      real xlat      
      REAL fk,vuk,sigk
      integer kh0
      integer iflag
      real pi
c
c DRAFT, drl 1 Nov 1999.  NEVER USED.
c
c invokes the IOS tidal subroutines to compute (f, freq, vu) for a
c   single tidal constituent konk. 
c
c kd0: Gregorain day; t_o is at the start of this day.
c konk: the tidal constituent of interest e.g. M2, 2MS2, ...
c xlat: decimal degrees latitude.
c fk: nodal amplitude modulation factor (dimensionless).
c vuk: V_o + u, evaluated at time t_o; radians.  
c freqk: harmonic frequency for this constituent, radians/sec.
c
      data IFLAG /0/
      SAVE
      kh0=kd0*24
      pi=acos(-1.0)
c
c if first call, initialize
c
      if(IFLAG.eq.0) then
        call OPNVUF(kh0,konk,xlat,fk,vuk,freqk)
        IFLAG=1
      endif     
c
c call vuf in IOS units:
c   input kh0 is Gregorian hour
c   vu is cycles
c   freq is cycles/hour
c   
      call VUF(kh0,konk,xlat,fk,vuk,freqk) 
c
c convert to NML units
c   vu is radians
c   freq is radians/sec
c
      vuk=vuk*2.*pi
      freqk=freqk*2.*pi/3600.
c
      return
      end
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C***********************************************************************
C***********************************************************************
C END OF GOMPAK
C END OF GOMPAK
C***********************************************************************
C***********************************************************************
C***********************************************************************
C***********************************************************************
C BEGINNING OF MATPAK
C BEGINNING OF MATPAK
C***********************************************************************
C***********************************************************************
C
C MAXPAK
C
C**********************************************************************
C**********************************************************************
C
C  SUBROUTINE DOOLITTLEDP
C  Christopher E. Naimie - Fall 1990
C  Dartmouth College
C  Latest Revision - 4/2/92
C
C This is a double precision FORTRAN subroutine which solves a set of
C   linear equations for {x} using the Doolittle Method.
C
C   The form of the system of equations is [A]*{x}={b}
C       [A] and {b} must be provided by the calling routine
C       the subroutine returns the {x} solution in {b}
C       the original {b} is destroyed by the routine
C
C   n=number of equations
C   m=option
C
C   There are 3 options:
C       1.- Perform LU decomposition only
C       2.- Perform back-substitution only
C       3.- Perform both 1 and 2
C
C----------------------------------------------------------------------
      SUBROUTINE DOOLITTLEDP(A,b,n,m)
      implicit double precision (a-h,o-z)
      dimension A(n,n),b(n)
C
C Check validity of option
C
      if(m.LT.1.OR.m.GT.3)then
         write(*,*)'SUBROUTINE DOOLITTLE requires m=1, m=2,or m=3.'
         write(*,*)'     you have specified m=',m
         STOP
      endif
      if(m.EQ.2)go to 2
C
C  Perform the LU decomposition and store the elements of [L] and [U]
C    in [A] except for the L(n,n) elements which, by definition, equal 1
C 
C  For the Doolittle Method of LU decomposition the first row of [A]
C    becomes the first row of [U]
C  Thus the first step is to calculate the first column of [L].
C
      do 10 i=2,n
         A(i,1)=A(i,1)/A(1,1)
 10   continue
C  
C  Determine rows of [U] and then columns of [L]
C
      do 40 i=2,n
         do 25 j=i,n
            sum=0.0d0
            do 20 k=1,i-1
               sum=sum+A(i,k)*A(k,j)
 20         continue
            A(i,j)=A(i,j)-sum
 25      continue
         do 35 j=i+1,n
            sum=0.0d0
            do 30 k=1,i-1
               sum=sum+A(j,k)*A(k,i)
 30         continue
            A(j,i)=(A(j,i)-sum)/A(i,i)
 35      continue
 40   continue
       if(m.EQ.1)return
C
C  Perform forward-substitution on [L]
C
 2    do 50 i=2,n
         sum=0.0d0
         do 45 j=1,i-1
            sum=sum+A(i,j)*b(j)
 45      continue
         b(i)=b(i)-sum
 50   continue
C
C  Perform back-substitution on [U]
C
      b(n)=b(n)/A(n,n)
      do 60 i=1,n-1
         sum=0.0d0
         do 55 j=1,i
            sum=sum+A(n-i,n-j+1)*b(n-j+1)
 55      continue
         b(n-i)=(b(n-i)-sum)/A(n-i,n-i)
 60   continue
       return
       end
C**********************************************************************
C**********************************************************************
C
C  SUBROUTINE DOOLITTLESP
C  Christopher E. Naimie - Fall 1990
C  Dartmouth College
C  Latest Revision - 4/2/92
C
C This is a single precision FORTRAN subroutine which solves a set of
C   linear equations for {x} using the Doolittle Method.
C
C   The form of the system of equations is [A]*{x}={b}
C       [A] and {b} must be provided by the calling routine
C       the subroutine returns the {x} solution in {b}
C       the original {b} is destroyed by the routine
C
C   n=number of equations
C   m=option
C
C   There are 3 options:
C       1.- Perform LU decomposition only
C       2.- Perform back-substitution only
C       3.- Perform both 1 and 2
C
C----------------------------------------------------------------------
      SUBROUTINE DOOLITTLESP(nndim,n,A,b,m)
      dimension A(nndim,nndim),b(nndim)
C
C Check validity of option
C
      if(m.LT.1.OR.m.GT.3)then
         write(*,*)'SUBROUTINE DOOLITTLE requires m=1, m=2,or m=3.'
         write(*,*)'     you have specified m=',m
         STOP
      endif
      if(m.EQ.2)go to 2
C
C  Perform the LU decomposition and store the elements of [L] and [U]
C    in [A] except for the L(n,n) elements which, by definition, equal 1
C 
C  For the Doolittle Method of LU decomposition the first row of [A]
C    becomes the first row of [U]
C  Thus the first step is to calculate the first column of [L].
C
      do 10 i=2,n
         A(i,1)=A(i,1)/A(1,1)
 10   continue
C  
C  Determine rows of [U] and then columns of [L]
C
      do 40 i=2,n
         do 25 j=i,n
            sum=0.0
            do 20 k=1,i-1
               sum=sum+A(i,k)*A(k,j)
 20         continue
            A(i,j)=A(i,j)-sum
 25      continue
         do 35 j=i+1,n
            sum=0.0 
            do 30 k=1,i-1
               sum=sum+A(j,k)*A(k,i)
 30         continue
            A(j,i)=(A(j,i)-sum)/A(i,i)
 35      continue
 40   continue
       if(m.EQ.1)return
C
C  Perform forward-substitution on [L]
C
 2    do 50 i=2,n
         sum=0.0 
         do 45 j=1,i-1
            sum=sum+A(i,j)*b(j)
 45      continue
         b(i)=b(i)-sum
 50   continue
C
C  Perform back-substitution on [U]
C
      b(n)=b(n)/A(n,n)
      do 60 i=1,n-1
         sum=0.0 
         do 55 j=1,i
            sum=sum+A(n-i,n-j+1)*b(n-j+1)
 55      continue
         b(n-i)=(b(n-i)-sum)/A(n-i,n-i)
 60   continue
       return
       end
C**********************************************************************
C**********************************************************************
      SUBROUTINE THOMAS(KKK,A,B,C,R,N)            
C-----------------------------------------------------------------------
C THOMAS ALGORITHM FOR TRIDIAGONAL MATRICES  -  SYSTEM FORTRAN-77
C REAL VERSION
C A, B, AND C = LHS COLUMNS, DIMENSIONED (=>N) IN CALLING PROGRAM
C R = RIGHT-HAND-SIDE, DIMENSIONED (=>N) IN CALLING PROGRAM 
C N = # OF EQUATIONS             
C SOLUTION RETURNS IN R WHEN KKK => 2
C KKK = 1 PERFORMS LU DECOMPOSITION DESTRUCTIVELY            
C KKK = 2 PERFORMS BACK SUBSTITUTION
C KKK = 3 PERFORMS OPTIONS 1 AND 2
C-----------------------------------------------------------------------
      DIMENSION A(N),B(N),C(N),R(N)
C                                                                       
C  STEP 1 - TRIANGULARIZE MATRIX A USING DOOLITTLE METHOD
C
      IF(KKK.EQ.2)GO TO 45
      C(1)=C(1)/B(1)           
      DO 40 I=2,N              
      IM=I-1            
      C(I)=C(I)/(B(I)-A(I)*C(IM))            
   40 CONTINUE
      IF(KKK.EQ.1)RETURN
C                
C STEP 2 - MODIFY LOAD VECTOR R 
C
   45 CONTINUE
      R(1)=R(1)/B(1)           
      DO 41 I=2,N              
      IM=I-1            
      R(I)=(R(I)-A(I)*R(IM))/(B(I)-A(I)*C(IM))      
   41 CONTINUE          
C
C BACK SUBSTITUTE SOLUTION INTO R VECTOR
C                
      DO 50 I=1,N-1            
      J=N-I             
      JP=J+1            
      R(J)=R(J)-C(J)*R(JP)            
   50 CONTINUE          
      RETURN            
      END
C**********************************************************************
C**********************************************************************
      SUBROUTINE CTHOMAS(KKK,A,B,C,R,N)
C
C THOMAS ALGORITHM FOR TRIDIAGONAL MATRICES  -  SYSTEM FORTRAN-77
C COMPLEX VERSION
C A, B, AND C = LHS COLUMNS, DIMENSIONED (=>N) IN CALLING PROGRAM
C R = RIGHT-HAND-SIDE, DIMENSIONED (=>N) IN CALLING PROGRAM
C N = # OF EQUATIONS
C SOLUTION RETURNS IN R WHEN KKK => 2
C KKK = 1 PERFORMS LU DECOMPOSITION DESTRUCTIVELY
C KKK = 2 PERFORMS BACK SUBSTITUTION
C KKK = 3 PERFORMS OPTIONS 1 AND 2
C
      COMPLEX A(N),B(N),C(N),R(N)
C
C  STEP 1 - TRIANGULARIZE MATRIX A USING DOOLITTLE METHOD
C
      IF(KKK.EQ.2)GO TO 45
      C(1)=C(1)/B(1)
      DO 40 I=2,N
      IM=I-1
      C(I)=C(I)/(B(I)-A(I)*C(IM))
   40 CONTINUE
      IF(KKK.EQ.1)RETURN
C
C STEP 2 - MODIFY LOAD VECTOR R
C
   45 CONTINUE
      R(1)=R(1)/B(1)
      DO 41 I=2,N
      IM=I-1
      R(I)=(R(I)-A(I)*R(IM))/(B(I)-A(I)*C(IM))
   41 CONTINUE
 
C
C BACK SUBSTITUTE SOLUTION INTO R VECTOR
C
      DO 50 I=1,N-1
      J=N-I
      JP=J+1
      R(J)=R(J)-C(J)*R(JP)
   50 CONTINUE
      RETURN
      END
C**********************************************************************
C**********************************************************************
      SUBROUTINE SOLVETR(KKK,B,R,NEQ,IHALFB,NDIM,MDIM)        
C-----------------------------------------------------------------------
C   16 FEB 1992 -- SOLVES FOR B TRANSPOSED -- (COLUMN, ROW)
C                
C   ASYMMETRIC BAND MATRIX EQUATION SOLVER           
C   DOCTORED TO IGNORE ZEROS IN LU DECOMP. STEP      
C                
C   KKK=1 TRIANGULARIZES THE BAND MATRIX B           
C   KKK=2 SOLVES FOR RIGHT SIDE R, SOLUTION RETURNS IN R      
C-----------------------------------------------------------------------
               
      DIMENSION B(MDIM,ndim),R(NDIM)        
      NRS=NEQ-1           
      IHBP=IHALFB+1       
      IF (KKK.EQ.2) GO TO 30       
C                
C  TRIANGULARIZE MATRIX A USING DOOLITTLE METHOD     
C                
      DO 10 K=1,NRS       
      PIVOT=B(IHBP,k)              
      KK=K+1              
      KC=IHBP             
      DO 21 I=KK,NEQ      
      KC=KC-1             
      IF(KC.LE.0) GO TO 10         
      C=-B(KC,i)/PIVOT             
      IF (C.EQ.0.0) GO TO 21       
      B(KC,i)=C           
      KI=KC+1             
      LIM=KC+IHALFB       
      DO 20 J=KI,LIM      
      JC=IHBP+J-KC        
   20 B(J,i)=B(J,i)+C*B(JC,k)      
   21 CONTINUE            
   10 CONTINUE            
      GO TO 100           
C                
C  MODIFY LOAD VECTOR R            
C                
   30 NN=NEQ+1            
      IBAND=2*IHALFB+1             
      DO 40 I=2,NEQ       
      JC=IHBP-I+1         
      JI=1       
      IF (JC.LE.0) GO TO 50        
      GO TO 60            
   50 JC=1       
      JI=I-IHBP+1         
   60 SUM=0.0             
      DO 70 J=JC,IHALFB            
      SUM=SUM+B(J,i)*R(JI)         
   70 JI=JI+1             
   40 R(I)=R(I)+SUM       
C                
C   BACK SOLUTION         
C                
      R(NEQ)=R(NEQ)/B(IHBP,neq)             
      DO 80 IBACK=2,NEQ            
      I=NN-IBACK          
      JP=I       
      KR=IHBP+1           
      MR=MIN(IBAND,IHALFB+IBACK)           
      SUM=0.0             
      DO 90 J=KR,MR       
      JP=JP+1             
   90 SUM=SUM+B(J,i)*R(JP)         
   80 R(I)=(R(I)-SUM)/B(IHBP,i)             
  100 RETURN              
      END
C**********************************************************************
C**********************************************************************
      SUBROUTINE CSOLVET(KKK,B,R,NEQ,IHALFB,NDIM,MDIM)
C
C   ASYMMETRIC BAND MATRIX EQUATION SOLVER
C   COMPLEX VERSION
C   DOCTORED TO IGNORE ZEROS IN LU DECOMP. STEP
C
C   KKK=1 TRIANGULARIZES THE BAND MATRIX B
C   KKK=2 SOLVES FOR RIGHT SIDE R, SOLUTION RETURNS IN R
C
      COMPLEX  B(MDIM,NDIM),R(NDIM)
      COMPLEX  PIVOT,C,SUM
      NRS=NEQ-1
      IHBP=IHALFB+1
      IF (KKK.EQ.2) GO TO 30
C
C  TRIANGULARIZE MATRIX A USING DOOLITTLE METHOD
C
      DO 10 K=1,NRS
      PIVOT=B(IHBP,K)
      KK=K+1
      KC=IHBP
      DO 21 I=KK,NEQ
      KC=KC-1
      IF(KC.LE.0) GO TO 10
      C=-B(KC,I)/PIVOT
      B(KC,I)=C
      IF(ABS(C).EQ.0.0) GO TO 21
      KI=KC+1
      LIM=KC+IHALFB
      DO 20 J=KI,LIM
      JC=IHBP+J-KC
   20 B(J,I)=B(J,I)+C*B(JC,K)
   21 CONTINUE
   10 CONTINUE
      GO TO 100
C
C  MODIFY LOAD VECTOR R
C
   30 NN=NEQ+1
      IBAND=2*IHALFB+1
      DO 40 I=2,NEQ
      JC=IHBP-I+1
      JI=1
      IF (JC.LE.0) GO TO 50
      GO TO 60
   50 JC=1
      JI=I-IHBP+1
   60 SUM=0.0
      DO 70 J=JC,IHALFB
      SUM=SUM+B(J,I)*R(JI)
   70 JI=JI+1
   40 R(I)=R(I)+SUM
C
C   BACK SOLUTION
C
      R(NEQ)=R(NEQ)/B(IHBP,NEQ)
      DO 80 IBACK=2,NEQ
      I=NN-IBACK
      JP=I
      KR=IHBP+1
      MR=MIN(IBAND,IHALFB+IBACK)
      SUM=0.0
      DO 90 J=KR,MR
      JP=JP+1
   90 SUM=SUM+B(J,I)*R(JP)
   80 R(I)=(R(I)-SUM)/B(IHBP,I)
  100 RETURN
      END
C**********************************************************************
C**********************************************************************
      SUBROUTINE BANSOLtr(KKK,B,R,NEQ,IBAND,NDIM,MDIM)
C-----------------------------------------------------------------------
C SYSTEM FORTRAN-77
C
C     TRANSPOSED VERSION of BANSOL (DRL 8 MARCH 94):
C            B(column, row)
C            Sequence of calling arguments unchanged from BANSOL
C
C B = LHS MATRIX , DIMENSIONED (mDIM,nDIM) IN CALLING PROGRAM
C R = RIGHT-HAND-SIDE, DIMENSIONED (NDIM) IN CALLING PROGRAM
C NEQ= # OF EQUATIONS
C IBAND = DIAGONAL(COLUMN 1) + HALF-BANDWIDTH
C SOLUTION RETURNS IN R
C KKK = 1 PERFORMS LU DECOMPOSITION DESTRUCTIVELY
C KKK = 2 PERFORMS BACK SUBSTITUTION
C KKK = 3 PERFORMS OPTIONS 1 AND 2
C
C     SYMMETRIC BAND MATRIX EQUATION SOLVER,   (REF, 2)
C     DOCTORED TO IGNORE ZEROS IN LU DECOMP. STEP (DRL 8 MARCH 94)
C     TRANSPOSED VERSION: B(column, row) (DRL 8 MARCH 94)
C-----------------------------------------------------------------------
      DIMENSION B(mDIM,nDIM), R(NDIM)
      NRS = NEQ - 1
      NR = NEQ
      IF(KKK .EQ. 2) GO TO 200
C
C  TRIANGULARIZE MATRIX A USING DOOLITTLE METHOD
C
      DO 120 N = 1,NRS
      M= N-1
      MR=MIN(IBAND,NR-M)
      PIVOT = B(1,N)
      DO  120 L=2,MR
      CP= B(l,N)/PIVOT
      IF (CP.EQ.0.0) GO TO 120
      I = M+L
      J = 0
      DO 110 K=L,MR
      J = J + 1
  110 B(j,I)= B(j,I) -CP*B(k,N)
  120 B(l,N) = CP
      IF(KKK.EQ.1)GO TO 400
C
C  MODIFY LOAD VECTOR R
C
  200 DO 220 N=1,NRS
      M= N-1
      MR = MIN(IBAND,NR-M)
      CP= R(N)
      R(N)=CP/B(1,N)
      DO 220  L=2,MR
      I = M + L
  220 R(I)=R(I)-B(l,N)*CP
C
C   BACK SOLUTION
C
      R(NR) = R(NR)/B(1,NR)
      DO 320 I = 1,NRS
      N=NR-I
      M= N-1
      MR=MIN(IBAND,NR-M)
      DO 320 K = 2,MR
      L = M+K
C     STORE COMPUTED DISPLACEMENTS IN LOAD VECTOR R
  320 R(N)= R(N)- B(k,N)*R(L)
  400 RETURN
      END
C**********************************************************************
C**********************************************************************
      SUBROUTINE RHSMULT(A,X,R,JX,NN,NB,NX,NB2DIM)
C-----------------------------------------------------------------------
C DRL, 9 March 1994
C
C Performs the matrix algebra r=r-A*x for known r, A, and x
C A and x are undisturbed; r is overwritten as above
C
C r is a n-length vector
C A is a matrix in column-banded, column-condensed form:
C     A(row, column) is A((2*nb+1), nx)
C x is a n-length vector
C
C Column condensation:
C   JX(k) is a pointer from local to global node number
C   JX(k) is the global column number of column k in A
C       A(*,j) multiplies x(jx(j))
C
C Column-banding:
C   Columns stored have total band height 2NB+1
C   The column is stored beginning in row 1
C   The main diagonal is at row NB+1
C
C NB is the half-bandheight (Full BW=2*NB+1)
C NX is the number of columns in A (Number of Type I BC's)
C NN is the length of the r and x vectors (Number of nodes globally)
C NB2DIM is the first physical dimension of A in the main program
C    --- NB2DIM.ge.(2*NB+1) ---
C-----------------------------------------------------------------------
      DIMENSION A(NB2DIM,*), R(*), X(*),JX(*)
C
C Check dimensions passed
C
      NB2=2*NB+1
      IF (NB2DIM.LT.NB2) THEN
         WRITE(*,*) ' INSUFFICIENT DIMENSION FOR MATRIX A IN'//
     &              ' SUBROUTINE RHSMULT'
         WRITE(*,*) ' NB2DIM =', NB2DIM, ' NB2 =', NB2
         WRITE(*,*) ' EXECUTION TERMINATED'
         STOP
      ENDIF
C
      DO 10 J=1,NX
C
C IR is the global row number (Position in r)
C I is the local row number in A (column-banded)
C J  is the local column number in A (columns are condensed)
C JX is the global column number (Position in x)
C Row correspondence:  I = (NB+1) + (IR-JX(J))    
C
      IR1 = MAX(1,JX(J)-NB)
      IR2 = MIN(NN,JX(J)+NB)
      I  = NB+1 + (IR1-JX(J))
C
      DO 20 IR=IR1,IR2
      R(IR)=R(IR)-A(I,J)*X( JX(J) )
      I=I+1
   20 CONTINUE
C
   10 CONTINUE
      RETURN
      END
C**********************************************************************
C**********************************************************************
C END OF MAXPAK
C END OF MAXPAK
C**********************************************************************
C**********************************************************************
C**********************************************************************
C**********************************************************************
C BEGINNING OF SPRSPAK
C BEGINNING OF SPRSPAK
C*********************************************************************
C*********************************************************************
C
C  SPRSPAK: APRIL 18, 1991.  D.R. LYNCH, K.D. PAULSEN, W. LIU
C  NUMERICAL METHODS LABORATORY, DARTMOUTH COLLEGE, HANOVER, NH.
C
C  REVISION: APRIL 19, 2000.  C.E.NAIMIE - Modifications which 
C  make the routines more in line with F77 standards ... but do not 
C  alter functionality in any way:
C            1. Replaced "1)" in dimensioning statements to "*)"
C            2. Replaced "(0.0,0.0)" and "(.0,.0)" complex assignments
C                 with "CMPLX(0.0,0.0)" 
C            3. Replaced calls to F77 "specific" intrinsic functions
C                 to "generic" form
C
C*********************************************************************
C*********************************************************************
C  BUILDING THE POINTERS IQ, JQ
C  BUILDING THE POINTERS IQ, JQ
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSBLD(IN,NDIM,NNE,IQ,JQ,NN,NE)
C
C  NDIM IS FIRST PHYSICAL DIMENSION OF IN(NDIM,NELEMENTS)
C     (NORMALLY NDIM IS 3 OR 4)
C  NNE INDICATES THAT IN(I,L) FOR I=1 THRU NNE ARE NODE NUMBERS; THE 
C     REST ARE ASSUMED TO BE ELEMENT PROPERTY INDICES
C  NN IS THE ACTUAL NUMBER OF NODES
C  NE IS THE ACTUAL NUMBER OF ELEMENTS
C  IQ(I) IS THE ADDRESS IN QV OF THE LAST NONZERO ENTRY IN ROW I OF Q
C  JQ(K) IS THE COLUMN INDEX IN Q FOR QV(K)
C
      DIMENSION IN(NDIM,*),IQ(*),JQ(*)
C
C  INITIALIZE AS DIAGONAL MATRIX
C
      DO 10 I=1,NN
      IQ(I)=I
      JQ(I)=I
   10 CONTINUE
C
C  ELEMENT LOOP
C
      DO 100 L=1,NE
      DO 90 I=1,NNE
      II=IN(I,L)
      DO 90 J=1,NNE
      JJ=IN(J,L)
      IF(I.NE.J) CALL SPRSINSRT(II,JJ,IQ,JQ,NN)
   90 CONTINUE
  100 CONTINUE
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSBLD1(IN,NDIM,NNE,IQ,JQ,NN,NE,MN,NDF)
C
C  NOVEMBER 30, 1990
C  D.LYNCH REVISION OF K.PAULSEN REVISION OF WEIPING VERSION.
C  SIMPLE ADAPTATION OF SPRSBLDW1 BY REVERSING ORDER OF IN(,) ARGUMENTS.
C
C  BUILDS SPRSPAK ARRAYS IQ,JQ FROM ELEMENT INCIDENCE LIST IN(K,L)
C     WITH L=GLOBAL ELEMENT NUMBER, K=LOCAL NODE NUMBER
C     FOR NDF DEGREES OF FREEDOM AT EACH NODE -- i.e. 
C     NDF EQUATIONS AND NDF UNKNOWNS.
C     NDF IS THE SAME AT EACH NODE.
C
C  SAME AS SPRSBLDW1 EXCEPT FOR THE ORDER OF THE ARGUMENTS FOR THE IN 
C  ARRAY
C 
C  NDIM IS THE FIRST PHYSICAL DIMENSION OF IN; NDIM.GE.NNE
C  NNE INDICATES THAT IN(I,L) FOR I=1 THRU NNE ARE NODE NUMBERS; 
C     THE BALANCE (IF ANY) OF IN WILL BE IGNORED.  
C  IQ(I) IS THE ADDRESS IN QV OF THE LAST NONZERO ENTRY IN ROW I OF Q
C  JQ(K) IS THE COLUMN INDEX IN Q FOR QV(K)
C  NN IS THE ACTUAL NUMBER OF NODES
C  NE IS THE ACTUAL NUMBER OF ELEMENTS
C  MN EQUALS OR EXCEEDS THE MAXIMUM NUMBER OF NONZREO ENTRYS PER ROW, 
C     FOR A SCALAR (i.e. NDF=1) PROBLEM.
C  NDF IS THE DEGREES OF FREEDOM, ASSUMED THE SAME AT EACH NODE.
C
C  IT IS ASSUMED THAT IN MAIN PROGRAM, DIMENSIONS ARE AT LEAST 
C     IQ(NN*NDF), JQ((NN*NDF)*(MN*NDF)).  NOTE THAT JQ IS OVERSIZED; 
C     BUT THE ALGORITHM MAY USE THIS EXTRA SIZE.  
C
C  CALLS ARE MADE TO SPRSINSRTD AND SPRSBLD3DD
C
      DIMENSION IN(NDIM,*),IQ(*),JQ(*)
C
C  INITIALIZE JQ
C
       DO 5 I=1,NN*MN
       JQ(I)=0
    5 CONTINUE
C
C  INITIALIZE JQ AS DIAGONAL MATRIX
C
      DO 10 I=1,NN
      J=(I-1)*MN+1
      JQ(J)=I
   10 CONTINUE
C
C  ELEMENT LOOP FOR JQ, ASSUMING NDF=1.
C  ALL ROWS ALLOWED MN ENTRIES.
C  TRAILING ZEROS WILL BE REMOVED BELOW.
C
      DO 100 L=1,NE
      DO 90 I=1,NNE
      II=IN(I,L)
      DO 90 J=1,NNE
      JJ=IN(J,L)
      IF(I.NE.J) CALL SPRSINSRTD(II,JJ,JQ,MN)
   90 CONTINUE
  100 CONTINUE
C
C FIND IQ FROM JQ
C
       K=0
       KK=0
       DO 110 I=1,NN
       DO 120 J=1,MN
       KK=KK+1
       IF(JQ(KK).NE.0) K=K+1
  120 CONTINUE
       IQ(I)=K
  110 CONTINUE      
C
C REARRANGE (CONDENSE) THE JQ -- REMOVE THE TRAILING ZEROS
C
       DO 140 I=2,NN
        KMIN=IQ(I-1)+1
        KMAX=IQ(I)
        KJMIN=(I-1)*MN+1
        DO 130 K=KMIN,KMAX
          JQ(K)=JQ(KJMIN)
          KJMIN=KJMIN+1
  130 CONTINUE
  140 CONTINUE
C
C IQ, JQ NOW CORRECT FOR NDF=1
C EXPAND FOR NDF.GT.1
C
        IF (NDF.GT.1) THEN
	CALL SPRSBLD3DD(IQ,JQ,NN,NDF)
	ELSE
	 GO TO 200
        END IF
  200 RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSBLDV(IN,NDIM,NNE,IQ,JQ,NN,NE,MN,NDOF,
     * NROWS,NENTRIES)
C
C  DECEMBER 17, 1990.  D.R.LYNCH.
C   (FROM SPRSBLD1, NOVEMBER 30, 1990.
C     GENERALIZES SPRSBLD1 TO ALLOW NDOF(I), i.e. A VARIABLE NUMBER OF 
C     D.O.F.  SUBROUTINE SPRSNDFV REPLACES SUBROUTINE SPRSBLD3DD.)
C
C  BUILDS SPRSPAK ARRAYS IQ,JQ FROM ELEMENT INCIDENCE LIST IN(K,L)
C     WITH L=GLOBAL ELEMENT NUMBER, K=LOCAL NODE NUMBER
C     FOR NDOF(I) DEGREES OF FREEDOM AT NODE I -- i.e. 
C     NDOF(I) EQUATIONS AND NDOF(I) UNKNOWNS AT NODE I.
C
C  SAME AS SPRSBLDWV EXCEPT FOR THE ORDER OF THE ARGUMENTS FOR THE IN ARRAY
C 
C  NDIM IS THE FIRST PHYSICAL DIMENSION OF IN; NDIM.GE.NNE
C  NNE INDICATES THAT IN(I,L) FOR I=1 THRU NNE ARE NODE NUMBERS; 
C     THE BALANCE (IF ANY) OF IN WILL BE IGNORED.  
C  IQ(I) IS THE ADDRESS IN QV OF THE LAST NONZERO ENTRY IN ROW I OF Q
C  JQ(K) IS THE COLUMN INDEX IN Q FOR QV(K)
C  NN IS THE ACTUAL NUMBER OF NODES
C  NE IS THE ACTUAL NUMBER OF ELEMENTS
C  MN EQUALS OR EXCEEDS THE MAXIMUM NUMBER OF NONZREO ENTRYS PER ROW, 
C     FOR A SCALAR (i.e. NDF=1) PROBLEM.
C  NDOF(I) IS THE DEGREES OF FREEDOM AT NODE I.
C  NROWS RETURNS WITH THE TOTAL NUMBER OF ROWS
C  NENTRIES RETURNS WITH THE TOTAL NUMBER OF NONZERO ENTRIES IN THE MATRIX
C
C  IT IS ASSUMED THAT IN MAIN PROGRAM, DIMENSIONS ARE AT LEAST 
C     IQ(NN*NDF), JQ((NN*NDF)*(MN*NDF)).  NOTE THAT JQ IS OVERSIZED; 
C     BUT THE ALGORITHM MAY USE THIS EXTRA SIZE.  
C
C  CALLS ARE MADE TO SPRSINSRTD AND SPRSNDFV
C
      DIMENSION IN(NDIM,*),IQ(*),JQ(*),NDOF(*)
C
C  INITIALIZE JQ
C
       DO 5 I=1,NN*MN
       JQ(I)=0
    5 CONTINUE
C
C  INITIALIZE JQ AS DIAGONAL MATRIX
C
      DO 10 I=1,NN
      J=(I-1)*MN+1
      JQ(J)=I
   10 CONTINUE
C
C  ELEMENT LOOP FOR JQ, ASSUMING NDF=1.
C  ALL ROWS ALLOWED MN ENTRIES.
C  TRAILING ZEROS WILL BE REMOVED BELOW.
C
      DO 100 L=1,NE
      DO 90 I=1,NNE
      II=IN(I,L)
      DO 90 J=1,NNE
      JJ=IN(J,L)
      IF(I.NE.J) CALL SPRSINSRTD(II,JJ,JQ,MN)
   90 CONTINUE
  100 CONTINUE
C
C FIND IQ FROM JQ
C
       K=0
       KK=0
       DO 110 I=1,NN
       DO 120 J=1,MN
       KK=KK+1
       IF(JQ(KK).NE.0) K=K+1
  120 CONTINUE
       IQ(I)=K
  110 CONTINUE      
C
C REARRANGE (CONDENSE) THE JQ -- REMOVE THE TRAILING ZEROS
C
       DO 140 I=2,NN
        KMIN=IQ(I-1)+1
        KMAX=IQ(I)
        KJMIN=(I-1)*MN+1
        DO 130 K=KMIN,KMAX
          JQ(K)=JQ(KJMIN)
          KJMIN=KJMIN+1
  130 CONTINUE
  140 CONTINUE
C
C IQ, JQ NOW CORRECT FOR NDOF(I)=1
C EXPAND FOR NDOF(I).GT.1
C
	CALL SPRSNDFV(IQ,JQ,NN,NDOF,NROWS,NENTRIES)
C
  200 RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSBLDW1(IN,NEDIM,NNE,IQ,JQ,NN,NE,MN,NDF)
C
C  NOVEMBER 30, 1990
C  D.LYNCH REVISION OF K.PAULSEN REVISION OF WEIPING VERSION
C
C  BUILDS SPRSPAK ARRAYS IQ,JQ FROM ELEMENT INCIDENCE LIST IN(L,K)
C     WITH L=GLOBAL ELEMENT NUMBER, K=LOCAL NODE NUMBER
C     FOR NDF DEGREES OF FREEDOM AT EACH NODE -- i.e. 
C     NDF EQUATIONS AND NDF UNKNOWNS.
C     NDF IS THE SAME AT EACH NODE.
C
C  SAME AS SPRSBLD1 EXCEPT FOR THE ORDER OF THE ARGUMENTS FOR THE IN ARRAY
C 
C  NEDIM IS THE FIRST PHYSICAL DIMENSION OF IN; NEDIM.GE.NE
C  NNE INDICATES THAT IN(L,I) FOR I=1 THRU NNE ARE NODE NUMBERS; 
C     THE BALANCE (IF ANY) OF IN WILL BE IGNORED.  
C  IQ(I) IS THE ADDRESS IN QV OF THE LAST NONZERO ENTRY IN ROW I OF Q
C  JQ(K) IS THE COLUMN INDEX IN Q FOR QV(K)
C  NN IS THE ACTUAL NUMBER OF NODES
C  NE IS THE ACTUAL NUMBER OF ELEMENTS
C  MN EQUALS OR EXCEEDS THE MAXIMUM NUMBER OF NONZREO ENTRYS PER ROW, 
C     FOR A SCALAR (i.e. NDF=1) PROBLEM.
C  NDF IS THE DEGREES OF FREEDOM, ASSUMED THE SAME AT EACH NODE.
C
C  IT IS ASSUMED THAT IN MAIN PROGRAM, DIMENSIONS ARE AT LEAST 
C     IQ(NN*NDF), JQ((NN*NDF)*(MN*NDF)).  NOTE THAT JQ IS OVERSIZED; 
C     BUT THE ALGORITHM MAY USE THIS EXTRA SIZE.  
C
C  CALLS ARE MADE TO SPRSINSRTD AND SPRSBLD3DD
C
      DIMENSION IN(NEDIM,*),IQ(*),JQ(*)
C
C  INITIALIZE JQ
C
       DO 5 I=1,NN*MN
       JQ(I)=0
    5 CONTINUE
C
C  INITIALIZE JQ AS DIAGONAL MATRIX
C
      DO 10 I=1,NN
      J=(I-1)*MN+1
      JQ(J)=I
   10 CONTINUE
C
C  ELEMENT LOOP FOR JQ, ASSUMING NDF=1.
C  ALL ROWS ALLOWED MN ENTRIES.
C  TRAILING ZEROS WILL BE REMOVED BELOW.
C
      DO 100 L=1,NE
      DO 90 I=1,NNE
      II=IN(L,I)
      DO 90 J=1,NNE
      JJ=IN(L,J)
      IF(I.NE.J) CALL SPRSINSRTD(II,JJ,JQ,MN)
   90 CONTINUE
  100 CONTINUE
C
C FIND IQ FROM JQ
C
       K=0
       KK=0
       DO 110 I=1,NN
       DO 120 J=1,MN
       KK=KK+1
       IF(JQ(KK).NE.0) K=K+1
  120 CONTINUE
       IQ(I)=K
  110 CONTINUE      
C
C REARRANGE (CONDENSE) THE JQ -- REMOVE THE TRAILING ZEROS
C
       DO 140 I=2,NN
        KMIN=IQ(I-1)+1
        KMAX=IQ(I)
        KJMIN=(I-1)*MN+1
        DO 130 K=KMIN,KMAX
          JQ(K)=JQ(KJMIN)
          KJMIN=KJMIN+1
  130 CONTINUE
  140 CONTINUE
C
C IQ, JQ NOW CORRECT FOR NDF=1
C EXPAND FOR NDF.GT.1
C
        IF (NDF.GT.1) THEN
	CALL SPRSBLD3DD(IQ,JQ,NN,NDF)
	ELSE
	 GO TO 200
        END IF
  200 RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSBLDWV(IN,NEDIM,NNE,IQ,JQ,NN,NE,MN,NDOF,
     * NROWS,NENTRIES)
C
C  DECEMBER 18, 1990
C   (FROM SPRSBLDV, DECEMBER 17,1990.  IN(,) INDICES REVERSED EVERYWHERE.)
C
C   (GENERALIZES SPRSBLDW1 TO ALLOW NDOF(I), i.e. A VARIABLE NUMBER OF 
C     D.O.F.  SUBROUTINE SPRSNDFV REPLACES SUBROUTINE SPRSBLD3DD.)
C
C  BUILDS SPRSPAK ARRAYS IQ,JQ FROM ELEMENT INCIDENCE LIST IN(L,K)
C     WITH L=GLOBAL ELEMENT NUMBER, K=LOCAL NODE NUMBER
C     FOR NDOF(I) DEGREES OF FREEDOM AT NODE I -- i.e. 
C     NDOF(I) EQUATIONS AND NDOF(I) UNKNOWNS AT NODE I.
C
C  SAME AS SPRSBLDV EXCEPT FOR THE ORDER OF THE ARGUMENTS FOR THE IN ARRAY
C 
C  NEDIM IS THE FIRST PHYSICAL DIMENSION OF IN; NEDIM.GE.NE
C  NNE INDICATES THAT IN(L,I) FOR I=1 THRU NNE ARE NODE NUMBERS; 
C     THE BALANCE (IF ANY) OF IN WILL BE IGNORED.  
C  IQ(I) IS THE ADDRESS IN QV OF THE LAST NONZERO ENTRY IN ROW I OF Q
C  JQ(K) IS THE COLUMN INDEX IN Q FOR QV(K)
C  NN IS THE ACTUAL NUMBER OF NODES
C  NE IS THE ACTUAL NUMBER OF ELEMENTS
C  MN EQUALS OR EXCEEDS THE MAXIMUM NUMBER OF NONZREO ENTRYS PER ROW, 
C     FOR A SCALAR (i.e. NDF=1) PROBLEM.
C  NDOF(I) IS THE DEGREES OF FREEDOM AT NODE I.
C  NROWS RETURNS WITH THE TOTAL NUMBER OF ROWS
C  NENTRIES RETURNS WITH THE TOTAL NUMBER OF NONZERO ENTRIES IN THE MATRIX
C
C  IT IS ASSUMED THAT IN MAIN PROGRAM, DIMENSIONS ARE AT LEAST 
C     IQ(NN*NDF), JQ((NN*NDF)*(MN*NDF)).  NOTE THAT JQ IS OVERSIZED; 
C     BUT THE ALGORITHM MAY USE THIS EXTRA SIZE.  
C
C  CALLS ARE MADE TO SPRSINSRTD AND SPRSNDFV
C
      DIMENSION IN(NEDIM,*),IQ(*),JQ(*),NDOF(*)
C
C  INITIALIZE JQ
C
       DO 5 I=1,NN*MN
       JQ(I)=0
    5 CONTINUE
C
C  INITIALIZE JQ AS DIAGONAL MATRIX
C
      DO 10 I=1,NN
      J=(I-1)*MN+1
      JQ(J)=I
   10 CONTINUE
C
C  ELEMENT LOOP FOR JQ, ASSUMING NDF=1.
C  ALL ROWS ALLOWED MN ENTRIES.
C  TRAILING ZEROS WILL BE REMOVED BELOW.
C
      DO 100 L=1,NE
      DO 90 I=1,NNE
      II=IN(L,I)
      DO 90 J=1,NNE
      JJ=IN(L,J)
      IF(I.NE.J) CALL SPRSINSRTD(II,JJ,JQ,MN)
   90 CONTINUE
  100 CONTINUE
C
C FIND IQ FROM JQ
C
       K=0
       KK=0
       DO 110 I=1,NN
       DO 120 J=1,MN
       KK=KK+1
       IF(JQ(KK).NE.0) K=K+1
  120 CONTINUE
       IQ(I)=K
  110 CONTINUE      
C
C REARRANGE (CONDENSE) THE JQ -- REMOVE THE TRAILING ZEROS
C
       DO 140 I=2,NN
        KMIN=IQ(I-1)+1
        KMAX=IQ(I)
        KJMIN=(I-1)*MN+1
        DO 130 K=KMIN,KMAX
          JQ(K)=JQ(KJMIN)
          KJMIN=KJMIN+1
  130 CONTINUE
  140 CONTINUE
C
C IQ, JQ NOW CORRECT FOR NDOF(I)=1
C EXPAND FOR NDOF(I).GT.1
C
	CALL SPRSNDFV(IQ,JQ,NN,NDOF,NROWS,NENTRIES)
C
  200 RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSINSRT(I,J,IQ,JQ,NN)
C
C  INSERTS GLOBAL ADDRESS (I,J) INTO IQ(),JQ()
C
      DIMENSION IQ(*),JQ(*)
      KMIN=1
      IF(I.NE.1)KMIN=IQ(I-1)+1
      KMAX=IQ(I)
C
C  SEARCH FOR INSERTION POINT KK
C
      DO 10 K=KMIN,KMAX
      KK=K
      IF(J.LT.JQ(K)) GO TO 20
      IF(J.EQ.JQ(K)) GO TO 50
   10 CONTINUE
      KK=KMAX+1
C
C  INSERT J AT JQ(KK); BUMP JQ
C
   20 DO 30 K=IQ(NN),KK,-1
   30 JQ(K+1)=JQ(K)
      JQ(KK)=J
C
C  AUGMENT THE IQ'S FROM I THRU NN
C
      DO 40 II=I,NN
   40 IQ(II)=IQ(II)+1   
C
C  DONE
C
   50 CONTINUE
      RETURN     
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSINSRTD(I,J,JQ,MN)
C
C  INSERTS GLOBAL ADDRESS (I,J) INTO JQ(), 
C  ASSUMING EXACTLY MN ENTRIES IN EACH ROW.
C
      DIMENSION JQ(*)
      KMIN=(I-1)*MN+1
      KMAX=I*MN
C
C  SEARCH FOR INSERTION POINT KK
C
      DO 10 K=KMIN,KMAX
      KK=K
      IF(J.LT.JQ(K)) GO TO 20
      IF(J.EQ.JQ(K)) GO TO 50
      IF(JQ(K).EQ.0) GO TO 20
   10 CONTINUE
C
C  INSERT J AT JQ(KK); BUMP JQ
C
C CHECK INSERTED BY K PAULSEN 11/29...NOT VALIDATED AT TIME OF
C INSERTION !!!!
C
   20 IF(JQ(KMAX).NE.0) THEN
       WRITE(*,*) 'MAX CONNECTIVITY MN=',MN,
     *  'VIOLATED AT I,J=',I,J,'IN SPRSINSRTD'
       STOP
      END IF
      DO 30 K=KMAX-1,KK,-1
   30 JQ(K+1)=JQ(K)
      JQ(KK)=J   
C
C  DONE
C
   50 CONTINUE
      RETURN     
      END
C
C*********************************************************************
C*********************************************************************
C
       SUBROUTINE SPRSBLD3DD(IQ,JQ,NN,NDF)
C
C BUILD 3D IDEX IQQ AND JQQ
C
       DIMENSION IQ(*),JQ(*)
	DO 60 I=NN,1,-1
	 IF (I.NE.1) THEN
	  II=IQ(I)-IQ(I-1)
	 ELSE
	  II=IQ(I)
	 END IF
	 DO 10 J=NDF,1,-1
	  IQ(NDF*(I-1)+J)=IQ(I)*NDF*NDF-(NDF-J)*NDF*II
   10	 CONTINUE
	 DO 30 K=1,II
	   JK=IQ(NDF*I)+1-(K-1)*NDF
	   IF (I.NE.1) THEN
	    JJ=JQ(IQ(I)-K+1)*NDF+1
	   ELSE
	    JJ=JQ(IQ(I)/NDF-K+1)*NDF+1
	   END IF
	  DO 20 J=1,NDF
	   JK=JK-1
	   JJ=JJ-1
C
C THE FOLLOWING 3 LINES FROM WEIPING'S CODE
C	   JQ(JK)=JJ
C	   JQ(JK-NDF*II)=JJ
C	   IF(NDF.EQ.3)	   JQ(JK-6*II)=JJ
C WORKED FOR NDF=2 OR 3.  REPLACED BY INDUCTION  
C WITH THE DO 15 LOOP BELOW (DRL 1 DECEMBER 1990).   
C IT IS NOT OBVIOUS THAT JQ REMAINS UNCORRUPTED IN THE 
C OVERWRITING.  
C
           DO 15 L=1,NDF
           JQ(JK-(L-1)*NDF*II)=JJ
   15      CONTINUE
   20	  CONTINUE
   30	 CONTINUE
   60	CONTINUE
        RETURN
        END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSNDFV(IQ,JQ,NN,NDOF,NROWS,NENTRIES)
C
C  DANIEL R. LYNCH, DEC. 17 1990
C  EXPANDS A SCALAR IQ, JQ ASSUMING NDOF(I) EQUATIONS AND UNKNOWNS AT NODE I.
C  ON RETURN, ORIGINAL IQ AND JQ HAVE BEEN OVERWRITTEN.
C  NROWS RETURNS AS THE NO. OF EQUATIONS
C  NENTRIES RETURNS AS THE NUMBER OF NONZERO MATRIX ENTRIES (LENGTH OF JQ).
C  
      PARAMETER(NNDIM=10000)
      DIMENSION NLOC(NNDIM)
      DIMENSION IQ(*),JQ(*),NDOF(*)
C
C CHECK DIMENSION OF LOCAL ARRAY
C
      IF(NN.GT.NNDIM) THEN
      WRITE(*,*) ' INSUFFICIENT DIMENSION IN SUB. SPRSNDFV'
      WRITE(*,*) ' NNDIM =', NNDIM, ' NN =',NN
      STOP
      ENDIF
C
C FORWARD LOOP TO FIND SIZE OF ARRAYS AND NLOC(I)
C
      NENTRIES=0
      NROWS=0
      DO 10 I=1,NN
      IF(I.EQ.1)THEN
      NLOC(1)=1
      K1=1
      ELSE
      NLOC(I) = NLOC(I-1)+NDOF(I-1)
      K1=IQ(I-1)+1
      ENDIF
      K2=IQ(I)
      KSUM=0
      DO 15 K=K1,K2
   15 KSUM=KSUM+NDOF(JQ(K))
      NENTRIES=NENTRIES+NDOF(I)*KSUM
      NROWS=NROWS+NDOF(I)
   10 CONTINUE
C
C BEGIN REWRITING IQ, JQ, BACKWARDS.
C
      KLONG=NENTRIES+1
      DO 90 I=NN,1,-1
         I1=NLOC(I)
         I2=I1+NDOF(I)-1
         K1=1
         IF(I.GT.1) K1=IQ(I-1)+1
         K2=IQ(I)
         DO 80 ILONG=I2,I1,-1
C
            IQ(ILONG)=KLONG-1
C
            DO 70 K=K2,K1,-1
               J1=NLOC(JQ(K))
               J2=J1+NDOF(JQ(K))-1
               DO 60 JLONG=J2,J1,-1
                  KLONG=KLONG-1
C
                  JQ(KLONG)=JLONG
C
   60 CONTINUE
   70 CONTINUE
   80 CONTINUE
   90 CONTINUE
      ILONG=ILONG+1
      IF(ILONG.NE.1) THEN
      WRITE(*,*) ' ILONG ENDED AT', ILONG,
     *     ' IN SUB. SPRSNDFV; TERMINATION.'
      STOP
      ENDIF
      IF(KLONG.NE.1) THEN
      WRITE(*,*) ' KLONG ENDED AT', KLONG, 
     *     ' IN SUB. SPRSNDFV; TERMINATION.'
      STOP
      ENDIF
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C  ADDRESSING THE QV ARRAY
C  ADDRESSING THE QV ARRAY
C*********************************************************************
C*********************************************************************
C
      FUNCTION KAY(I,J,IQ,JQ)
C
C  FINDS ADDRESS K IN QV FOR Q(I,J)
C
      DIMENSION IQ(*),JQ(*)
      KAY=IQ(I)+1
   10 KAY=KAY-1
      IF(JQ(KAY).NE.J)GO TO 10
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      FUNCTION KAYW(I,J,IQ,JQ)
C
C  FINDS ADDRESS K IN QV FOR Q(I,J)
C
      DIMENSION IQ(*),JQ(*)
	IF (I.EQ.1) THEN
	 IIQ=1
	ELSE
	 IIQ=IQ(I-1)+2
	END IF
	DO 10 K=IQ(I),IIQ,-1
	 IF(JQ(K).EQ.J) GO TO 20
   10	CONTINUE
   20	KAYW=K
	IF (JQ(K).NE.J) KAYW=0
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C  MANIPULATING THE QV ARRAY
C  MANIPULATING THE QV ARRAY
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSROWZAP(QV,IQ,I)
C
C  REPLACES ROW I OF QV WITH ZEROS
C
      DIMENSION QV(*),IQ(*)
      KMIN=1
      IF(I.GT.1) KMIN=IQ(I-1)+1
      KMAX=IQ(I)
      DO 20 K=KMIN,KMAX
   20 QV(K)=0.0
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
	SUBROUTINE SPRSROWZAP3(QV,IQ,I1,I2)
C
C  REPALCES ROWS I1 THRU I2 OF QV WITH ZEROS
C
	DIMENSION QV(*),IQ(*)
	KMIN=1
	IF(I1.GT.1) KMIN=IQ(I1-1)+1
	KMAX=IQ(I2)
	DO 20 K=KMIN,KMAX
   20	QV(K)=0.0
	RETURN
	END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSINVMLT(QV,IQ,D,NN)
C
C  REPLACES QV WITH INV(D)*QV
C  D IS A DIAGONAL MATRIX, LENGTH NN 
C  NN IS THE SIZE OF Q (# OF EQUATIONS)
C
      DIMENSION QV(*),D(*),IQ(*)
      KMAX=0
      DO 10 I=1,NN
      KMIN=KMAX+1
      KMAX=IQ(I)
      FTR=1./D(I)
      DO 20 K=KMIN,KMAX
   20 QV(K)=FTR*QV(K)
   10 CONTINUE
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSNORM(QV,IQ,NN)
C
C  CORRECTS QV SO THAT ROW SUMS ARE ZERO
C  THE CORRECTION IS SPREAD EVENLY OVER THE WHOLE ROW
C  NN IS THE SIZE OF Q (# OF EQUATIONS)
C  IQ(I) IS THE ADDRESS IN QV OF THE LAST NONZERO ENTRY IN ROW I OF Q
C
      DIMENSION QV(*),IQ(*)
      KMAX=0
      DO 10 I=1,NN
      KMIN=KMAX+1
      KMAX=IQ(I)
      SUM=0.0
      DO 20 K=KMIN,KMAX
   20 SUM=SUM+QV(K)
      CORR=SUM/(1.*(KMAX-KMIN+1))
      DO 25 K=KMIN,KMAX
   25 QV(K)=QV(K)-CORR
   10 CONTINUE
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
	SUBROUTINE SPRSSHRNK(A,IQ,JQ,N,TOL)
C
C A(I) STORED MATRIX A OF THE SYSTEM A*X=B
C IQ(I) IS THE ADDRESS IN A OF THE LAST NONZERO ENTRY IN ROW I OF A
C JQ(K) IS THE COLUMN INDEX IN A OF A(K)
C N IS NUMBER OF EQUATIONS
C NZ IS LOCAL ARRAY USED TO STORE THOSE ENTRIES THAT WILL BE REDUCED
C TOL IS THE ...
C NDIM IS THE LENGTH OF NZ; NO MORE THAN NDIM SMALL ENTRIES WILL BE REMOVED.
C
        PARAMETER(NDIM=10000)
	DIMENSION IQ(*),JQ(*),NZ(NDIM)
	COMPLEX*16 A(*)
        REAL*8 TOL
C
	NK=1
	DO 20 I=1,N
	 IF (I.EQ.1) THEN
	  II=1
	 ELSE
	  II=IQ(I-1)+1
	 END IF
	 DO 10 K=II,IQ(I)
	  IF ( CDABS(A(K)).LE.TOL) THEN
	   NZ(NK)=K
	   NK=NK+1
C
C CHECK INSERTED BY DAN AND KEITH 4/19/91
C
          IF (NK.GT.NDIM) THEN
          WRITE(*,*) 'NDIM IN SUBROUTINE SPRSSHRNK =', NDIM, 
     *'IS INSUFFICIENT;  TERMINATION OF SHRINK OCCURRED IN EQUATION', I, 
     *'POSITION', K, ' IN A'
          GO TO 200
          END IF
C
	  END IF
   10	 CONTINUE
   20	CONTINUE
C
  200 CONTINUE
C
	NK=NK-1
	N1=NZ(1)
	DO 40 I=1,NK
	 N2=NZ(I+1)-(I+1)
	 IF (I.EQ.NK) N2=IQ(N)+1-(I+1)
	 IF (N1.LE.N2) THEN
	  DO 30 J=N1,N2
	   A(J)=A(J+I)
	   JQ(J)=JQ(J+I)
   30	  CONTINUE
	 END IF
	 N1=NZ(I+1)-I
   40	CONTINUE
C
	JK=0
	MK=1
	DO 60 I=1,N
   50	 IF(NZ(MK).LE.IQ(I).AND.MK.LE.NK) THEN
	  MK=MK+1
	  JK=JK+1
	  GO TO 50
	 ELSE
	  IQ(I)=IQ(I)-JK
	 END IF
   60	CONTINUE
	RETURN
	END
C
C*********************************************************************
C*********************************************************************
C  MATRIX MULTIPLICATION
C  MATRIX MULTIPLICATION
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSMLT(QV,IQ,JQ,X,B,NN)
C
C  MULTIPLIES QV*X; ANSWER RETURNS IN B
C  NN IS THE SIZE OF Q (# OF EQUATIONS)
C
      DIMENSION QV(*),X(*),B(*),IQ(*),JQ(*)
      KMAX=0
      DO 10 I=1,NN
      SUM=0.
      KMIN=KMAX+1
      KMAX=IQ(I)
      DO 20 K=KMIN,KMAX
   20 SUM=SUM+QV(K)*X(JQ(K))
   10 B(I)=SUM
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE SPRSMLTCD(A,IA,JA,P,AP,N)
C
C  MULTIPLIES A*P; ANSWER RETURNS IN AP
C  N IS THE SIZE OF A (# OF EQUATIONS)
C  VERSION CD: COMPLEX DOUBLE PRECISION QV AND X
C
         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
         COMPLEX*16 A(*),P(*),AP(*)
         DIMENSION IA(*),JA(*)
         KMAX=0
        DO 20 I=1,N
          AP(I)=0.0
          KMIN=KMAX+1
          KMAX=IA(I)
          DO 10 J=KMIN,KMAX
           AP(I)=AP(I)+A(J)*P(JA(J))
10        CONTINUE
20       CONTINUE
        RETURN
        END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSMLTRC(QV,IQ,JQ,X,B,NN)
C
C  MULTIPLIES QV*X; ANSWER RETURNS IN B
C  NN IS THE SIZE OF Q (# OF EQUATIONS)
C  VERSION RC: REAL QV, COMPLEX X
C
      DIMENSION QV(*),IQ(*),JQ(*)
      COMPLEX X(*),B(*)
      COMPLEX SUM
      KMAX=0
      DO 10 I=1,NN
      SUM=CMPLX(0.0,0.0)
      KMIN=KMAX+1
      KMAX=IQ(I)
      DO 20 K=KMIN,KMAX
   20 SUM=SUM+QV(K)*X(JQ(K))
   10 B(I)=SUM
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSMLTI(I,QV,IQ,JQ,X,B)
C
C  MULTIPLIES THE Ith ROW OF QV BY THE VECTOR X; ANSWER RETURNS IN THE SCALAR B
C     (OR: OBTAINS ONLY Bi OF Q*X=B)
C  IQ,JQ ARE THE STANDARD POINTERS FOR QV
C  THIS ROUTINE IS NONDESTRUCTIVE
C
      DIMENSION QV(*),IQ(*),JQ(*),X(*)
      KMIN=1
      IF(I.GT.1) KMIN=IQ(I-1)+1
      KMAX=IQ(I)
      B=0.
      DO 20 K=KMIN,KMAX
   20 B=B+QV(K)*X(JQ(K))
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSMLTIJ(I,J,QV,IQ,JQ,X,B,NNDIM)
C
C  MULTIPLIES THE Ith ROW OF QV BY THE Jth COLUMN OF THE MATRIX X; 
C  ANSWER RETURNS IN THE SCALAR B
C     (OR: OBTAINS ONLY Bij OF Q*X=B)
C  IQ,JQ ARE THE STANDARD POINTERS FOR QV
C  NNDIM IS THE FIRST PHYSICAL DIMENSION OF X
C  THIS ROUTINE IS NONDESTRUCTIVE
C
      DIMENSION QV(*),IQ(*),JQ(*),X(NNDIM,*)
      KMIN=1
      IF(I.GT.1) KMIN=IQ(I-1)+1
      KMAX=IQ(I)
      B=0.
      DO 20 K=KMIN,KMAX
   20 B=B+QV(K)*X(JQ(K),J)
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSMLTIN(I,QV,IQ,JQ,X,B,NNV,NNDIM)
C
C  MULTIPLIES THE Ith ROW OF QV BY THE Jth COLUMN OF THE MATRIX X,
C     FOR ALL VALUES OF J FROM 1 TO NNV
C  ANSWER RETURNS IN THE VECTOR B
C     (OR: OBTAINS ONLY Bi OF Q*X=B)
C  IQ,JQ ARE THE STANDARD POINTERS FOR QV
C  NNDIM IS THE FIRST PHYSICAL DIMENSION OF X
C  THIS ROUTINE IS NONDESTRUCTIVE
C
      DIMENSION QV(*),IQ(*),JQ(*),X(NNDIM,*),B(*)
      KMIN=1
      IF(I.GT.1) KMIN=IQ(I-1)+1
      KMAX=IQ(I)
      DO 20 J=1,NNV
      B(J)=0.
      DO 10 K=KMIN,KMAX
   10 B(J)=B(J)+QV(K)*X(JQ(K),J)
   20 CONTINUE
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSCONV(I,PPX,PPY,IQ,JQ,U,V,Z,
     *  DUDX,DUDY,DVDX,DVDY,DZDX,DZDY,
     *  NNV,NNDIM)
C
C  COMPUTES THE HORIZONTAL DERIVATIVES AT DEPTH, UNDER HORIZONTAL NODE #I.
C  PPX, PPY ARE THE SPRSPAK MATRICES FOR D/DX, D/DY
C  IQ,JQ ARE THE STANDARD POINTERS FOR PPX, PPY
C  U(I,J),V(I,J) ARE THE X- AND Y-VELOCITIES 
C      AT HORIZONTAL NODE I, VERTICAL NODE J
C  Z(I,J) IS THE VERTICAL POSITION
C      OF HORIZONTAL NODE I, VERTICAL NODE J
C  THE HORIZONTAL DERIVATIVE TERMS DUDX(J), ETC. ARE RETURNED 
C      FOR ALL NODES J UNDER THE GIVEN NODE I
C  NNV IS THE ACTUAL # OF NODES IN THE VERTICAL
C  NNDIM IS THE FIRST PHYSICAL DIMENSION OF U AND V 
C  THIS ROUTINE IS NONDESTRUCTIVE
C
      DIMENSION PPX(*),PPY(*),IQ(*),JQ(*),
     * U(NNDIM,*),V(NNDIM,*),Z(NNDIM,*),
     * DUDX(*),DUDY(*),DVDX(*),DVDY(*),DZDX(*),DZDY(*)
      KMIN=1
      IF(I.GT.1) KMIN=IQ(I-1)+1
      KMAX=IQ(I)
      DO 20 J=1,NNV
      DUDX(J)=0.
      DUDY(J)=0.
      DVDX(J)=0.
      DVDY(J)=0.
      DZDX(J)=0.
      DZDY(J)=0.
      DO 10 K=KMIN,KMAX
      DUDX(J)=DUDX(J)+PPX(K)*U(JQ(K),J)
      DUDY(J)=DUDY(J)+PPY(K)*U(JQ(K),J)
      DVDX(J)=DVDX(J)+PPX(K)*V(JQ(K),J)
      DVDY(J)=DVDY(J)+PPY(K)*V(JQ(K),J)
      DZDX(J)=DZDX(J)+PPX(K)*Z(JQ(K),J)
      DZDY(J)=DZDY(J)+PPY(K)*Z(JQ(K),J)
   10 CONTINUE
   20 CONTINUE
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSCONVRC(I,PPX,PPY,IQ,JQ,U,V,Z,
     *  DUDX,DUDY,DVDX,DVDY,DZDX,DZDY,
     *  NNV,NNDIM)
C
C  VERSION RC: REAL PPX,PPY; COMPLEX U,V; REAL Z.
C  COMPUTES THE HORIZONTAL DERIVATIVES AT DEPTH, UNDER HORIZONTAL NODE #I.
C  PPX, PPY ARE THE SPRSPAK MATRICES FOR D/DX, D/DY
C  IQ,JQ ARE THE STANDARD POINTERS FOR PPX, PPY
C  U(I,J),V(I,J) ARE THE X- AND Y-VELOCITIES
C      AT HORIZONTAL NODE I, VERTICAL NODE J
C  Z(I,J) IS THE VERTICAL POSITION
C      OF HORIZONTAL NODE I, VERTICAL NODE J
C  THE HORIZONTAL DERIVATIVE TERMS DUDX(J), ETC. ARE RETURNED
C      FOR ALL NODES J UNDER THE GIVEN NODE I
C  NNV IS THE ACTUAL # OF NODES IN THE VERTICAL
C  NNDIM IS THE FIRST PHYSICAL DIMENSION OF U AND V
C  THIS ROUTINE IS NONDESTRUCTIVE
C
      DIMENSION PPX(*),PPY(*),IQ(*),JQ(*),Z(NNDIM,*),DZDX(*),DZDY(*)
      COMPLEX U(NNDIM,*),V(NNDIM,*),DUDX(*),DUDY(*),DVDX(*),DVDY(*)
      KMIN=1
      IF(I.GT.1) KMIN=IQ(I-1)+1
      KMAX=IQ(I)
      DO 20 J=1,NNV
      DUDX(J)=CMPLX(0.0,0.0)
      DUDY(J)=CMPLX(0.0,0.0)
      DVDX(J)=CMPLX(0.0,0.0)
      DVDY(J)=CMPLX(0.0,0.0)
      DZDX(J)=0.
      DZDY(J)=0.
      DO 10 K=KMIN,KMAX
      DUDX(J)=DUDX(J)+PPX(K)*U(JQ(K),J)
      DUDY(J)=DUDY(J)+PPY(K)*U(JQ(K),J)
      DVDX(J)=DVDX(J)+PPX(K)*V(JQ(K),J)
      DVDY(J)=DVDY(J)+PPY(K)*V(JQ(K),J)
      DZDX(J)=DZDX(J)+PPX(K)*Z(JQ(K),J)
      DZDY(J)=DZDY(J)+PPY(K)*Z(JQ(K),J)
   10 CONTINUE
   20 CONTINUE
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSGRAD(I,PPX,PPY,IQ,JQ,F,Z,
     *  DFDX,DFDY,DZDX,DZDY,
     *  NNV,NNDIM)
C 
C  A SIMPLE VARIANT OF SPRSCONV
C  COMPUTES THE HORIZONTAL GRADIENT OF F AT DEPTH, UNDER HORIZONTAL NODE #I.
C  PPX, PPY ARE THE SPRSPAK MATRICES FOR D/DX, D/DY
C  IQ,JQ ARE THE STANDARD POINTERS FOR PPX, PPY
C  F(I,J) IS A SCALAR FUNCTION DEFINED 
C      AT HORIZONTAL NODE I, VERTICAL NODE J
C  Z(I,J) IS THE VERTICAL POSITION
C      OF HORIZONTAL NODE I, VERTICAL NODE J
C  THE HORIZONTAL DERIVATIVE TERMS DFDX(J), DFDY(J) ARE RETURNED
C      FOR ALL NODES J UNDER THE GIVEN NODE I
C  NNV IS THE ACTUAL # OF NODES IN THE VERTICAL
C  NNDIM IS THE FIRST PHYSICAL DIMENSION OF F
C  THIS ROUTINE IS NONDESTRUCTIVE
C
      DIMENSION PPX(*),PPY(*),IQ(*),JQ(*),Z(NNDIM,*),DZDX(*),DZDY(*)
      DIMENSION F(NNDIM,*),DFDX(*),DFDY(*)
      KMIN=1
      IF(I.GT.1) KMIN=IQ(I-1)+1
      KMAX=IQ(I)
      DO 20 J=1,NNV
      DFDX(J)= 0.
      DFDY(J)= 0.
      DZDX(J)=0.
      DZDY(J)=0.
      DO 10 K=KMIN,KMAX
      DFDX(J)=DFDX(J)+PPX(K)*F(JQ(K),J)
      DFDY(J)=DFDY(J)+PPY(K)*F(JQ(K),J)
      DZDX(J)=DZDX(J)+PPX(K)*Z(JQ(K),J)
      DZDY(J)=DZDY(J)+PPY(K)*Z(JQ(K),J)
   10 CONTINUE
   20 CONTINUE
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
      SUBROUTINE SPRSGRADRC(I,PPX,PPY,IQ,JQ,F,Z,
     *  DFDX,DFDY,DZDX,DZDY,
     *  NNV,NNDIM)
C 
C  A SIMPLE VARIANT OF SPRSCONVRC
C  VERSION RC OF SPRSGRAD: REAL PPX,PPY; COMPLEX F; REAL Z.
C  COMPUTES THE HORIZONTAL GRADIENT OF F AT DEPTH, UNDER HORIZONTAL NODE #I.
C  PPX, PPY ARE THE SPRSPAK MATRICES FOR D/DX, D/DY
C  IQ,JQ ARE THE STANDARD POINTERS FOR PPX, PPY
C  F(I,J) IS A COMPLEX SCALAR FUNCTION DEFINED 
C      AT HORIZONTAL NODE I, VERTICAL NODE J
C  Z(I,J) IS THE VERTICAL POSITION
C      OF HORIZONTAL NODE I, VERTICAL NODE J
C  THE HORIZONTAL DERIVATIVE TERMS DFDX(J), DFDY(J) ARE RETURNED
C      FOR ALL NODES J UNDER THE GIVEN NODE I
C  NNV IS THE ACTUAL # OF NODES IN THE VERTICAL
C  NNDIM IS THE FIRST PHYSICAL DIMENSION OF F
C  THIS ROUTINE IS NONDESTRUCTIVE
C
      DIMENSION PPX(*),PPY(*),IQ(*),JQ(*),Z(NNDIM,*),DZDX(*),DZDY(*)
      COMPLEX F(NNDIM,*),DFDX(*),DFDY(*)
      KMIN=1
      IF(I.GT.1) KMIN=IQ(I-1)+1
      KMAX=IQ(I)
      DO 20 J=1,NNV
      DFDX(J)=CMPLX(0.0,0.0)
      DFDY(J)=CMPLX(0.0,0.0)
      DZDX(J)=0.
      DZDY(J)=0.
      DO 10 K=KMIN,KMAX
      DFDX(J)=DFDX(J)+PPX(K)*F(JQ(K),J)
      DFDY(J)=DFDY(J)+PPY(K)*F(JQ(K),J)
      DZDX(J)=DZDX(J)+PPX(K)*Z(JQ(K),J)
      DZDY(J)=DZDY(J)+PPY(K)*Z(JQ(K),J)
   10 CONTINUE
   20 CONTINUE
      RETURN
      END
C
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE SPRSMLTCDOR(A,IA,JA,P,AP,N,NDIM,KI)
C
C FOR USE IN ORTHOMIN SOLVERS
C
         IMPLICIT DOUBLE PRECISION (A-H,O-Z)
         COMPLEX*16 A(*),P(NDIM,*),AP(*)
         DIMENSION IA(*),JA(*)
        DO 20 I=1,N
          AP(I)=0.0
	  IF (I.EQ.1) THEN
	   KK=1
	  ELSE
	   KK=IA(I-1)+1
	  END IF
          DO 10 J=KK,IA(I)
           AP(I)=AP(I)+A(J)*P(JA(J),KI)
10        CONTINUE
20       CONTINUE
        RETURN
        END
C
C*********************************************************************
C*********************************************************************
C  SOLVERS
C  SOLVERS
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE CDCGS(A,X,R,TOL,IQ,JQ,ITMAX,N,IP)
C
C THIS SUBROUTINE IS A LINEAR SYSTEM SOLVER USING CGS ALGORITHM
C   WITHOUT PRECONDITIONING .
C
         IMPLICIT DOUBLE PRECISION(A-H,O-Z)
         PARAMETER (NDIM=5000)
         INTEGER JQ(*),IQ(*)
         COMPLEX*16 A(*),X(*),R(*)
	 COMPLEX*16 P(NDIM),Q(NDIM),U(NDIM),V(NDIM),R1(NDIM)
	 COMPLEX*16 ALPHA,BETA,S1,S2
         IF(N.GT.NDIM) THEN
          WRITE(*,*) 'INTERNAL SOLVER DIMENSIONS TOO SMALL'
          WRITE(*,*) 'CURRENT SETTING IS',NDIM
          WRITE(*,*) 'MUST BE GREATER OR EQUAL TO',N
          STOP
         END IF
         DO 5 I=1,N
          P(I)=R(I)
5        CONTINUE
         CALL SPRSMLTCD(A,IQ,JQ,X,R,N)
         DO 10 I=1,N
          R(I)=P(I)-R(I)
          R1(I)=CONJG(R(I))
	  Q(I)=R(I)
	  U(I)=R(I)
10       CONTINUE
         S1=CMPLX(0.0,0.0)
         DO 20 I=1,N
          S1=S1+R(I)*(R1(I))
20       CONTINUE
         DO 500 K=1,ITMAX
          CALL SPRSMLTCD(A,IQ,JQ,Q,P,N)
          S2=CMPLX(0.0,0.0)
          DO 100 I=1,N
            S2=S2+CONJG(R1(I))*(P(I))
100       CONTINUE
          ALPHA=S1/S2
          DO 200 I=1,N
           P(I)=U(I)-ALPHA*P(I)
           U(I)=ALPHA*(U(I)+P(I))
200       CONTINUE
	  CALL SPRSMLTCD(A,IQ,JQ,U,V,N)
          DO 380 I=1,N
 	   X(I)=X(I)+U(I)
 	   R(I)=R(I)-V(I)
380	 CONTINUE
         DELTA=0.0
         DO 250 I=1,N
          DELTA=DELTA+R(I)*CONJG(R(I))
250      CONTINUE
         DELTA=SQRT(DELTA)/N
         IF (IP.EQ.1) write(*,*) K,DELTA
         IF(DELTA.GT.1.0E+6) THEN
          WRITE(*,*) 'RESIDUAL SIZE IS',DELTA
          WRITE(*,*) 'CONVERGENCE QUESTIONABLE'
          WRITE(*,*) 'ITERATION STOPPED'
          STOP
         END IF
         IF(K.GT.ITMAX) THEN
          write(*,1001) TOL
          RETURN
         END IF
         IF(DELTA.LE.TOL) THEN
          write(*,1002) TOL,K
          RETURN
         END IF
         S2=CMPLX(0.0,0.0)
         DO 280 I=1,N
          S2=S2+CONJG(R1(I))*(R(I))
280      CONTINUE
	 BETA=S2/S1
	 S1=S2 
	 DO 420 I=1,N
	  U(I)=R(I)+BETA*P(I)
	  Q(I)=U(I)+BETA*(BETA*Q(I)+P(I))
420	 CONTINUE
500     CONTINUE
1002    FORMAT(/,1X,'DESIRED TOLERANCE....',1PE9.2,'  REACHED IN...',I5,
     &'  ITERATIONS')
1001    FORMAT(/,1X,'DESIRED TOLERANCE..',1PE9.2,' NOT REACHED IN.',I5,
     &'  ITERATIONS')
        END
C
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE CDCGSR(A,AM,X,R,TOL,IQ,JQ,ITMAX,N,IP)
C
C THIS SUBROUTINE IS A LINEAR SYSTEM SOLVER USING CGS ALGORITHM
C WITH  PRECONDITIONING FROM RIGHT.
C THE PRECONDITIONING MATRIX IS ASSUMED TO BE COMPUTED ALREADY, AND 
C   SUPPLIED IN SPARSE FORM IN THE MATRIX AM, WITH IQ AND JQ THE SAME AS FOR A.
C THERE ARE TWO PRECONDITIONERS AVAILABLE IN PRECONCD.FOR: MILU AND ILU
C
         IMPLICIT DOUBLE PRECISION(A-H,O-Z)
         PARAMETER (NDIM=5000)
         INTEGER JQ(*),IQ(*)
         COMPLEX*16 A(*),AM(*),X(*),R(*)
	 COMPLEX*16 P(NDIM),Q(NDIM),U(NDIM),V(NDIM),R1(NDIM)
	 COMPLEX*16 ALPHA,BETA,S1,S2
         IF(N.GT.NDIM) THEN
          WRITE(*,*) 'INTERNAL SOLVER DIMESNIONS TOO SMALL'
          WRITE(*,*) 'CURRENT SETTING IS',NDIM
          WRITE(*,*) 'MUST BE GREATER OR EQUAL TO',N
          STOP
         END IF
         DO 5 I=1,N
          P(I)=R(I)
5        CONTINUE
         CALL SPRSMLTCD(A,IQ,JQ,X,R,N)
         DO 10 I=1,N
          R(I)=P(I)-R(I)
          R1(I)=CONJG(R(I))
	  Q(I)=R(I)
	  U(I)=R(I)
	  P(I)=R(I)
10       CONTINUE
	 S1=CMPLX(0.0,0.0)
         DO 20 I=1,N
          S1=S1+R(I)*CONJG(R1(I))
20       CONTINUE
         DO 500 K=1,ITMAX
	  CALL DSOVM(AM,IQ,JQ,P,N)
          CALL SPRSMLTCD(A,IQ,JQ,P,V,N)
          S2=CMPLX(0.0,0.0)
          DO 100 I=1,N
            S2=S2+V(I)*CONJG(R1(I))
100       CONTINUE
          ALPHA=S1/S2
          DO 200 I=1,N
           P(I)=U(I)-ALPHA*V(I)
           U(I)=ALPHA*(U(I)+P(I))
200       CONTINUE
	  CALL DSOVM(AM,IQ,JQ,U,N)
 	  CALL SPRSMLTCD(A,IQ,JQ,U,V,N)
          DO 380 I=1,N
           X(I)=X(I)+U(I)
	   R(I)=R(I)-V(I)
380	  CONTINUE
         DELTA=0.0
         DO 250 I=1,N
          DELTA=DELTA+R(I)*CONJG(R(I))
250      CONTINUE
         DELTA=SQRT(DELTA)/N
         IF(IP.EQ.1) WRITE(*,*) K,DELTA
         IF(DELTA.GT.1.E+6) THEN
          WRITE(*,*) 'RESIDUAL SIZE IS',DELTA
          WRITE(*,*) 'CONVERGENCE QUESTIONABLE'
          WRITE(*,*) 'ITERATION STOPPED'
          STOP
         END IF
         IF(K.GT.ITMAX) THEN
          WRITE(*,1001) TOL
          RETURN
         END IF
         IF(DELTA.LE.TOL) THEN
          WRITE(*,1002) TOL,K
          RETURN
         END IF
	 S2=CMPLX(0.0,0.0)
         DO 400 I=1,N
          S2=S2+R(I)*CONJG(R1(I))
400       CONTINUE
	 BETA=S2/S1
	 S1=S2
	DO 420 I=1,N
	  U(I)=R(I)+BETA*P(I)
	  Q(I)=U(I)+BETA*(BETA*Q(I)+P(I))
	  P(I)=Q(I)
420	CONTINUE
500     CONTINUE
1002    FORMAT(/,1X,'DESIRED TOLERANCE....',1PE9.2,' REACHED IN....',I5,
     &'  ITERATIONS')
1001    FORMAT(/,1X,'DESIRED TOLERANCE..',1PE9.2,' NOT REACHED IN..',I5,
     &'  ITERATIONS')
        END
C
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE CDCGSL(A,AM,X,R,TOL,IQ,JQ,ITMAX,N,IP)
C
C THIS SUBROUTINE IS A LINEAR SYSTEM SOLVER USING CGS ALGORITHM
C WITH  PRECONDITIONING FROM LEFT.
C THE PRECONDITIONING MATRIX IS ASSUMED TO BE COMPUTED ALREADY, AND 
C   SUPPLIED IN SPARSE FORM IN THE MATRIX AM, WITH IQ AND JQ THE SAME AS FOR A.
C THERE ARE TWO PRECONDITIONERS AVAILABLE IN PRECONCD.FOR: MILU AND ILU
C
         IMPLICIT DOUBLE PRECISION(A-H,O-Z)
         PARAMETER (NDIM=5000)
         INTEGER JQ(*),IQ(*)
         COMPLEX*16 A(*),AM(*),X(*),R(*)
	 COMPLEX*16 P(NDIM),Q(NDIM),U(NDIM),V(NDIM),R1(NDIM)
	 COMPLEX*16 ALPHA,BETA,S1,S2
         IF(N.GT.NDIM) THEN
          WRITE(*,*) 'INTERNAL SOLVER DIMENSIONS TOO SMALL'
          WRITE(*,*) 'CURRENT SETTING IS',NDIM
          WRITE(*,*) 'MUST BE GREATER OR EQUAL TO',N
          STOP
         END IF
         DO 1 I=1,N
          P(I)=R(I)
 1       CONTINUE
         CALL SPRSMLTCD(A,IQ,JQ,X,R,N)
         DO 5 I=1,N
          R(I)=P(I)-R(I)
	  R1(I)=R(I)
 5       CONTINUE
	 CALL DSOVM(AM,IQ,JQ,R1,N)
         DO 10 I=1,N
	  Q(I)=R1(I)
	  U(I)=R1(I)
	  R1(I)=(R1(I))
 10      CONTINUE
	 S1=CMPLX(0.0,0.0)
	 DO 20 I=1,N
	  S1=S1+R1(I)*(R1(I))
 20      CONTINUE
         DO 500 K=1,ITMAX
          CALL SPRSMLTCD(A,IQ,JQ,Q,P,N)
  	  CALL DSOVM(AM,IQ,JQ,P,N)
          S2=CMPLX(0.0,0.0)
          DO 100 I=1,N
            S2=S2+(R1(I))*(P(I))
 100      CONTINUE
          ALPHA=S1/S2
          DO 200 I=1,N
          P(I)=U(I)-ALPHA*P(I)
          U(I)=ALPHA*(U(I)+P(I))
 200      CONTINUE
	  CALL SPRSMLTCD(A,IQ,JQ,U,V,N)
         DO 380 I=1,N
	  X(I)=X(I)+U(I)
          R(I)=R(I)-V(I)
	  V(I)=R(I)
 380	 CONTINUE
         DELTA=0.0
         DO 250 I=1,N
          DELTA=DELTA+R(I)*CONJG(R(I))
 250      CONTINUE
         DELTA=SQRT(DELTA)/N
         IF(IP.EQ.1) WRITE(*,*) K,DELTA
         IF(DELTA.GT.1.E+6) THEN
          WRITE(*,*) 'RESIDUAL SIZE IS',DELTA
          WRITE(*,*) 'CONVERGENCE QUESTIONABLE'
          WRITE(*,*) 'ITERATION STOPPED'
          STOP
         END IF
	 IF(K.GT.ITMAX) THEN
	  WRITE(*,1001) TOL
	  RETURN
	 END IF
         IF(DELTA.LE.TOL) THEN
          WRITE(*,1002) TOL,K
          RETURN
         END IF
  	  CALL DSOVM(AM,IQ,JQ,V,N)
          S2=CMPLX(0.0,0.0)
          DO 280 I=1,N
           S2=S2+(R1(I))*(V(I))
 280       CONTINUE
          BETA=S2/S1
	  S1=S2
	  DO 320 I=1,N
	   U(I)=V(I)+BETA*P(I)
	   Q(I)=U(I)+BETA*(BETA*Q(I)+P(I))
 320	  CONTINUE
 500     CONTINUE
 1002    FORMAT(/,1X,'DESIRED TOLERANCE....',1PE9.2,' REACHED IN..',I5,
     &'  ITERATIONS')
 1001    FORMAT(/,1X,'DESIRED TOLERANCE..',1PE9.2,'NOT REACHED IN..',I5,
     &'  ITERATIONS')
        END
C
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE CDCGSLD(A,X,R,TOL,IQ,JQ,ITMAX,N,IP)
C
C THIS SUBROUTINE IS A LINEAR SYSTEM SOLVER USING CGS ALGORITHM
C WITH  DIAGONAL PRECONDITIONING FROM LEFT.
C THE DIAGONAL PRECONDITIONER IS COMPUTED WITHIN, BY A CALL TO DDIAG.
C
         IMPLICIT DOUBLE PRECISION(A-H,O-Z)
         PARAMETER (NDIM=5000)
         INTEGER JQ(*),IQ(*)
         COMPLEX*16 A(*),X(*),R(*)
	 COMPLEX*16 P(NDIM),Q(NDIM),AM(NDIM),U(NDIM),V(NDIM),R1(NDIM)
	 COMPLEX*16 ALPHA,BETA,S1,S2
         IF(N.GT.NDIM) THEN
          WRITE(*,*) 'INTERNAL SOLVER DIMENSIONS TOO SMALL'
          WRITE(*,*) 'CURRENT SETTING IS',NDIM
          WRITE(*,*) 'MUST BE GREATER OR EQUAL TO',N
          STOP
         END IF
         DO 2 I=1,N
          P(I)=R(I)
 2        CONTINUE
         CALL DDIAG(A,AM,IQ,JQ,N)
         CALL SPRSMLTCD(A,IQ,JQ,X,R,N)
         DO 5 I=1,N
          R(I)=P(I)-R(I)
	  R1(I)=R(I)
 5        CONTINUE
	 CALL DSOVMD(AM,R1,N)
         DO 10 I=1,N
	  Q(I)=R1(I)
	  U(I)=R1(I)
	  R1(I)=(R1(I))
 10       CONTINUE
	 S1=CMPLX(0.0,0.0)
	 DO 20 I=1,N
	  S1=S1+R1(I)*(R1(I))
 20	 CONTINUE
         DO 500 K=1,ITMAX
          CALL SPRSMLTCD(A,IQ,JQ,Q,P,N)
  	  CALL DSOVMD(AM,P,N)
          S2=CMPLX(0.0,0.0)
          DO 100 I=1,N
            S2=S2+(R1(I))*(P(I))
 100       CONTINUE
          ALPHA=S1/S2
          DO 200 I=1,N
          P(I)=U(I)-ALPHA*P(I)
          U(I)=ALPHA*(U(I)+P(I))
 200      CONTINUE
	  CALL SPRSMLTCD(A,IQ,JQ,U,V,N)
         DO 380 I=1,N
	  X(I)=X(I)+U(I)
          R(I)=R(I)-V(I)
	  V(I)=R(I)
 380	 CONTINUE
         DELTA=0.0
         DO 250 I=1,N
          DELTA=DELTA+R(I)*CONJG(R(I))
 250      CONTINUE
         DELTA=SQRT(DELTA)/N
         IF(IP.EQ.1) WRITE(*,*) K,DELTA
         IF(DELTA.GT.1.E+6) THEN
          WRITE(*,*) 'RESIDUAL SIZE IS',DELTA
          WRITE(*,*) 'CONVERGENCE QUESTIONABLE'
          WRITE(*,*) 'ITERATION STOPPED'
          STOP
         END IF
	 IF(K.GT.ITMAX) THEN
	  WRITE(*,1001) TOL
	  RETURN
	 END IF
         IF(DELTA.LE.TOL) THEN
          WRITE(*,1002) TOL,K
          RETURN
         END IF
  	  CALL DSOVMD(AM,V,N)
          S2=CMPLX(0.0,0.0)
          DO 280 I=1,N
           S2=S2+(R1(I))*(V(I))
 280       CONTINUE
          BETA=S2/S1
	  S1=S2
	  DO 320 I=1,N
	   U(I)=V(I)+BETA*P(I)
	   Q(I)=U(I)+BETA*(BETA*Q(I)+P(I))
 320	  CONTINUE
 500     CONTINUE
 1002    FORMAT(/,1X,'DESIRED TOLERANCE....',1PE9.2,'  REACHED IN..',I5,
     &'  ITERATIONS')
 1001    FORMAT(/,1X,'DESIRED TOLERANCE..',1PE9.2,' NOT REACHED IN.',I5,
     &'  ITERATIONS')
        END
C
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE CDCGSRD(A,X,R,TOL,IQ,JQ,ITMAX,N,IP)
C
C THIS SUBROUTINE IS A LINEAR SYSTEM SOLVER USING CGS ALGORITHM
C WITH  DIAGONAL PRECONDITIONING FROM RIGHT.
C THE DIAGONAL PRECONDITIONER IS COMPUTED WITHIN, BY A CALL TO DDIAG.
C
         IMPLICIT DOUBLE PRECISION(A-H,O-Z)
         PARAMETER (NDIM=5000)
         INTEGER JQ(*),IQ(*)
         COMPLEX*16 A(*),X(*),R(*)
	 COMPLEX*16 P(NDIM),Q(NDIM),AM(NDIM),U(NDIM),V(NDIM),R1(NDIM)
	 COMPLEX*16 ALPHA,BETA,S1,S2
         IF(N.GT.NDIM) THEN
          WRITE(*,*) 'INTERNAL SOLVER DIMESNIONS TOO SMALL'
          WRITE(*,*) 'CURRENT SETTING IS',NDIM
          WRITE(*,*) 'MUST BE GREATER OR EQUAL TO',N
          STOP
         END IF
         DO 5 I=1,N
          P(I)=R(I)
 5        CONTINUE
         CALL DDIAG(A,AM,IQ,JQ,N)
         CALL SPRSMLTCD(A,IQ,JQ,X,R,N)
         DO 10 I=1,N
          R(I)=P(I)-R(I)
          R1(I)=conjg(R(I))
	  Q(I)=R(I)
	  U(I)=R(I)
	  P(I)=R(I)
 10       CONTINUE
	 S1=CMPLX(0.0,0.0)
         DO 20 I=1,N
          S1=S1+R(I)*CONJG(R1(I))
 20       CONTINUE
         DO 500 K=1,ITMAX
	  CALL DSOVMD(AM,P,N)
          CALL SPRSMLTCD(A,IQ,JQ,P,V,N)
          S2=CMPLX(0.0,0.0)
          DO 100 I=1,N
            S2=S2+V(I)*CONJG(R1(I))
 100       CONTINUE
          ALPHA=S1/S2
          DO 200 I=1,N
           P(I)=U(I)-ALPHA*V(I)
           U(I)=ALPHA*(U(I)+P(I))
 200       CONTINUE
	  CALL DSOVMD(AM,U,N)
 	  CALL SPRSMLTCD(A,IQ,JQ,U,V,N)
          DO 380 I=1,N
           X(I)=X(I)+U(I)
	   R(I)=R(I)-V(I)
 380	  CONTINUE
         DELTA=0.0
         DO 250 I=1,N
          DELTA=DELTA+R(I)*CONJG(R(I))
 250      CONTINUE
         DELTA=SQRT(DELTA)/N
         IF(IP.EQ.1) WRITE(*,*) K,DELTA
         IF(DELTA.GT.1.E+6) THEN
          WRITE(*,*) 'RESIDUAL SIZE IS',DELTA
          WRITE(*,*) 'CONVERGENCE QUESTIONABLE'
          WRITE(*,*) 'ITERATION STOPPED'
          STOP
         END IF
         IF(K.GT.ITMAX) THEN
          WRITE(*,1001) TOL
          RETURN
         END IF
         IF(DELTA.LE.TOL) THEN
          WRITE(*,1002) TOL,K
          RETURN
         END IF
	 S2=CMPLX(0.0,0.0)
         DO 400 I=1,N
          S2=S2+R(I)*CONJG(R1(I))
 400       CONTINUE
	 BETA=S2/S1
	 S1=S2
	DO 420 I=1,N
	  U(I)=R(I)+BETA*P(I)
	  Q(I)=U(I)+BETA*(BETA*Q(I)+P(I))
	  P(I)=Q(I)
 420	CONTINUE
 500     CONTINUE
 1002    FORMAT(/,1X,'DESIRED TOLERANCE....',1PE9.2,' REACHED IN..',I5,
     &'  ITERATIONS')
 1001    FORMAT(/,1X,'DESIRED TOLERANCE..',1PE9.2,' NOT REACHED IN.',I5,
     &'  ITERATIONS')
        END
C
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE CDORTHOMIN(A,X,R,TOL,IA,JA,ITMAX,N,KN,IP)
C
C THIS SUBROUTINE IS A LINEAR SYSTEM SOLVER USING ORTHOMIN(K) ALGORITHM
C 
         IMPLICIT DOUBLE PRECISION(A-H,O-Z)
         PARAMETER (NDIM=5000)
         PARAMETER (KMAX=11)
         DIMENSION JA(*),IA(*)
         COMPLEX*16 A(*),X(*),R(*)
	 COMPLEX*16 P(NDIM,KMAX),AMP(NDIM),AR(NDIM),AP(NDIM)
	 COMPLEX*16 ALPHA,DOTN,BETA(KMAX)
         IF(KN.GE.KMAX) THEN
          WRITE(*,*) 'K OF ORTHOMIN(K) TOO LARGE'
          WRITE(*,*) 'MAXIMUM ALLOWED K IS',KMAX-1
          WRITE(*,*) 'ITERATION STOPPED'
          STOP
         END IF
         IF(NDIM.LT.N) THEN
          WRITE(*,*) 'INTERNAL SOLVER DIMENSIONS TOO SMALL'
          WRITE(*,*) 'CURRENT SETTING IS',NDIM
          WRITE(*,*) 'MUST BE GREATER OR EQUAL TO',N
          STOP
         END IF
         DO 2 I=1,N
          P(I,KN+1)=0.0
          P(I,KN)=R(I)
 2        CONTINUE
         DO 4 K=1,KN-1
          DO 3 I=1,N
           P(I,K)=0.0
 3         CONTINUE
 4        CONTINUE
         CALL SPRSMLTCD(A,IA,JA,X,R,N)
         DO 5 I=1,N
          R(I)=P(I,KN)-R(I)
	  AR(I)=R(I)
 5        CONTINUE
         DO 10 I=1,N
          P(I,KN)=AR(I)
 10       CONTINUE
	 delta1=0.0
         DO 500 K=1,ITMAX
	  IK=MIN(K,KN)
	  IK=KN-IK+1
	  CALL SPRSMLTCDOR(A,IA,JA,P,AP,N,NDIM,KN)
          DOTN=CMPLX(0.0,0.0)
          DOTD=0.0
          DO 100 I=1,N
            DOTN=DOTN+R(I)*CONJG(AP(I))
            DOTD=DOTD+AP(I)*CONJG(AP(I))
 100       CONTINUE
         ALPHA=DOTN/DOTD
         DO 200 I=1,N
          X(I)=X(I)+ALPHA*P(I,KN)
          R(I)=R(I)-ALPHA*AP(I)
	  AR(I)=R(I)
	  P(I,KN+1)=0
 200      CONTINUE
         IF(K.GT.ITMAX) THEN
          WRITE(*,1001) TOL
          RETURN
         END IF
         DELTA=0.0
         DO 250 I=1,N
          DELTA=DELTA+R(I)*CONJG(R(I))
 250      CONTINUE
         DELTA=SQRT(DELTA)/N
         IF(IP.EQ.1) WRITE(*,*) K,DELTA
	 if (delta.eq.delta1) THEN
          WRITE(*,*) 'METHOD STALLED'
          WRITE(*,*) 'ITERATION STOPPED AT',K
          RETURN
         END IF
	 delta1=delta
         IF(DELTA.LE.TOL) THEN
          WRITE(*,1002) TOL,K
          RETURN
         END IF
	  CALL SPRSMLTCD(A,IA,JA,AR,AMP,N)
	DO 300 J=IK,KN
	  CALL SPRSMLTCDOR(A,IA,JA,P,AP,N,NDIM,J)
          DOTN=CMPLX(0.0,0.0)
	  DOTD=0.0
          DO 280 I=1,N
           DOTN=DOTN+AMP(I)*CONJG(AP(I))
	   DOTD=DOTD+AP(I)*CONJG(AP(I))
 280     CONTINUE
        BETA(J)=-DOTN/DOTD
 300	CONTINUE
	DO 400 J=IK,KN
          DO 380 I=1,N
          P(I,KN+1)=BETA(J)*P(I,J)+P(I,KN+1)
 380	 CONTINUE
 400     CONTINUE
	DO 420 I=1,N
	  P(I,KN+1)=P(I,KN+1)+AR(I)
 420	CONTINUE
	DO 450 J=1,KN
	 DO 430 I=1,N
	  P(I,J)=P(I,J+1)
 430	 CONTINUE
 450	CONTINUE
 500     CONTINUE
 1002    FORMAT(/,1X,'DESIRED TOLERANCE....',1PE9.2,'  REACHED IN..',I5,
     &'  ITERATIONS')
 1001    FORMAT(/,1X,'DESIRED TOLERANCE..',1PE9.2,' NOT REACHED IN.',I5,
     &'  ITERATIONS')
        END
C
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE CDORTHOMINL(A,AM,X,R,TOL,IA,JA,ITMAX,N,KN,IP)
C
C THIS SUBROUTINE IS A LINEAR SYSTEM SOLVER USING ORTHOMIN(K) ALGORITHM
C WITH  PRECONDITIONING FROM LEFT.
C THE PRECONDITIONING MATRIX IS ASSUMED TO BE COMPUTED ALREADY, AND 
C   SUPPLIED IN SPARSE FORM IN THE MATRIX AM, WITH IQ AND JQ THE SAME AS FOR A.
C THERE ARE TWO PRECONDITIONERS AVAILABLE IN PRECONCD.FOR: MILU AND ILU
C
         IMPLICIT DOUBLE PRECISION(A-H,O-Z)
         PARAMETER (NDIM=5000)
         PARAMETER (KMAX=11)
         DIMENSION JA(*),IA(*)
         COMPLEX*16 A(*),X(*),R(*),AM(*)
	 COMPLEX*16 P(NDIM,KMAX),AMP(NDIM),AR(NDIM),AP(NDIM)
	 COMPLEX*16 ALPHA,DOTN,BETA(KMAX)
         IF(KN.GE.KMAX) THEN
          WRITE(*,*) 'K OF ORTHOMIN(K) TOO LARGE'
          WRITE(*,*) 'MAXIMUM ALLOWED K IS',KMAX-1
          WRITE(*,*) 'ITERATION STOPPED'
          STOP
         END IF
         IF(NDIM.LT.N) THEN
          WRITE(*,*) 'INTERNAL SOLVER DIMENSIONS TOO SMALL'
          WRITE(*,*) 'CURRENT SETTING IS',NDIM
          WRITE(*,*) 'MUST BE GREATER OR EQUAL TO',N
          STOP
         END IF
         DO 2 I=1,N
          P(I,KN+1)=0.0
          P(I,KN)=R(I)
 2        CONTINUE
         DO 4 K=1,KN-1
          DO 3 I=1,N
           P(I,K)=0.0
 3         CONTINUE
 4        CONTINUE
         DELTAOLD=0.0
         CALL SPRSMLTCD(A,IA,JA,X,R,N)
         DO 5 I=1,N
          R(I)=P(I,KN)-R(I)
 5        CONTINUE
	 CALL DSOVM(AM,IA,JA,R,N)
         DO 10 I=1,N
          P(I,KN)=R(I)
 10       CONTINUE
         DO 500 K=1,ITMAX
	  IK=MIN(K,KN)
	  IK=KN-IK+1
	  CALL SPRSMLTCDOR(A,IA,JA,P,AMP,N,NDIM,KN)
	  CALL DSOVM(AM,IA,JA,AMP,N) 
          DOTN=CMPLX(0.0,0.0)
          DOTD=0.0
          DO 100 I=1,N
            DOTN=DOTN+R(I)*CONJG(AMP(I))
            DOTD=DOTD+AMP(I)*CONJG(AMP(I))
 100       CONTINUE
         ALPHA=DOTN/DOTD
         DO 200 I=1,N
          X(I)=X(I)+ALPHA*P(I,KN)
          R(I)=R(I)-ALPHA*AMP(I)
	  P(I,KN+1)=0
 200      CONTINUE
         IF(K.GT.ITMAX) THEN
          WRITE(*,1001) TOL
          RETURN
         END IF
         DELTA=0.0
         DO 250 I=1,N
          DELTA=DELTA+R(I)*CONJG(R(I))
 250      CONTINUE
         DELTA=SQRT(DELTA)/N
         IF(IP.EQ.1) WRITE(*,*) K,DELTA
         IF(DELTA.EQ.DELTAOLD) THEN
          WRITE(*,*) 'METHOD STALLED'
          WRITE(*,*) 'ITERATION STOPPED AT',K
          RETURN
         END IF
         DELTAOLD=DELTA
         IF(DELTA.LE.TOL) THEN
          WRITE(*,1002) TOL,K
          RETURN
         END IF
	  CALL SPRSMLTCD(A,IA,JA,R,AR,N)
	  CALL DSOVM(AM,IA,JA,AR,N)
        DO 300 J=IK,KN
	 CALL SPRSMLTCDOR(A,IA,JA,P,AMP,N,NDIM,J)
	 CALL DSOVM(AM,IA,JA,AMP,N)
	 DOTN=CMPLX(0.0,0.0)
	 DOTD=0.0
	 DO 280 I=1,N
          DOTN=DOTN+AR(I)*CONJG(AMP(I))
	  DOTD=DOTD+AMP(I)*CONJG(AMP(I))
 280	 CONTINUE
        BETA(J)=-DOTN/DOTD
 300     CONTINUE
	DO 400 J=IK,KN
         DO 380 I=1,N
          P(I,KN+1)=BETA(J)*P(I,J)+P(I,KN+1)
 380	 CONTINUE
 400     CONTINUE
	DO 420 I=1,N
	  P(I,KN+1)=P(I,KN+1)+R(I)
 420	CONTINUE
	DO 450 J=1,KN
	 DO 430 I=1,N
	  P(I,J)=P(I,J+1)
 430	 CONTINUE
 450	CONTINUE
 500     CONTINUE
 1002    FORMAT(/,1X,'DESIRED TOLERANCE....',1PE9.2,'  REACHED IN..',I5,
     &'  ITERATIONS')
 1001    FORMAT(/,1X,'DESIRED TOLERANCE..',1PE9.2,' NOT REACHED IN.',I5,
     &'  ITERATIONS')
        END
C
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE CDORTHOMINR(A,AM,X,R,TOL,IA,JA,ITMAX,N,KN,IP)
C
C THIS SUBROUTINE IS A LINEAR SYSTEM SOLVER USING ORTHOMIN(K) ALGORITHM
C WITH  PRECONDITIONING FROM RIGHT.
C THE PRECONDITIONING MATRIX IS ASSUMED TO BE COMPUTED ALREADY, AND 
C   SUPPLIED IN SPARSE FORM IN THE MATRIX AM, WITH IQ AND JQ THE SAME AS FOR A.
C THERE ARE TWO PRECONDITIONERS AVAILABLE IN PRECONCD.FOR: MILU AND ILU
C
         IMPLICIT DOUBLE PRECISION(A-H,O-Z)
         PARAMETER (NDIM=5000)
         PARAMETER (KMAX=11)
         DIMENSION JA(*),IA(*)
         COMPLEX*16 A(*),AM(*),X(*),R(*)
	 COMPLEX*16 P(NDIM,KMAX),AMP(NDIM),AR(NDIM),AP(NDIM)
	 COMPLEX*16 ALPHA,DOTN,BETA(KMAX)
         IF(KN.GE.KMAX) THEN
          WRITE(*,*) 'K OF ORTHOMIN(K) TOO LARGE'
          WRITE(*,*) 'MAXIMUM ALLOWED K IS',KMAX-1
          WRITE(*,*) 'ITERATION STOPPED'
          STOP
         END IF
         IF(NDIM.LT.N) THEN
          WRITE(*,*) 'INTERNAL SOLVER DIMENSIONS TOO SMALL'
          WRITE(*,*) 'CURRENT SETTING IS',NDIM
          WRITE(*,*) 'MUST BE GREATER OR EQUAL TO',N
          STOP
         END IF
         DO 2 I=1,N
          P(I,KN+1)=0.0
          P(I,KN)=R(I)
 2        CONTINUE
         DO 4 K=1,KN-1
          DO 3 I=1,N
           P(I,K)=0.0
 3         CONTINUE
 4        CONTINUE
         DELTAOLD=0.0
         CALL SPRSMLTCD(A,IA,JA,X,R,N)
         DO 5 I=1,N
          R(I)=P(I,KN)-R(I)
	  AR(I)=R(I)
 5        CONTINUE
	 CALL DSOVM(AM,IA,JA,AR,N)
         DO 10 I=1,N
          P(I,KN)=AR(I)
 10       CONTINUE
         DO 500 K=1,ITMAX
	  IK=MIN(K,KN)
	  IK=KN-IK+1
	  CALL SPRSMLTCDOR(A,IA,JA,P,AP,N,NDIM,KN)
          DOTN=CMPLX(0.0,0.0)
          DOTD=0.0
          DO 100 I=1,N
            DOTN=DOTN+R(I)*CONJG(AP(I))
            DOTD=DOTD+AP(I)*CONJG(AP(I))
 100       CONTINUE
         ALPHA=DOTN/DOTD
         DO 200 I=1,N
          X(I)=X(I)+ALPHA*P(I,KN)
          R(I)=R(I)-ALPHA*AP(I)
	  AR(I)=R(I)
	  P(I,KN+1)=0
 200      CONTINUE
         IF(K.GT.ITMAX) THEN
          WRITE(*,1001) TOL
          RETURN
         END IF
         DELTA=0.0
         DO 250 I=1,N
          DELTA=DELTA+R(I)*CONJG(R(I))
 250      CONTINUE
         DELTA=SQRT(DELTA)/N
         IF(IP.EQ.1) WRITE(*,*) K,DELTA
         IF(DELTA.EQ.DELTAOLD) THEN
          WRITE(*,*) 'METHOD STALLED'
          WRITE(*,*) 'ITERATION STOPPED AT', K
          RETURN
         END IF
         DELTAOLD=DELTA
         IF(DELTA.LE.TOL) THEN
          WRITE(*,1002) TOL,K
          RETURN
         END IF
	  CALL DSOVM(AM,IA,JA,AR,N)
	  CALL SPRSMLTCD(A,IA,JA,AR,AMP,N)
	DO 300 J=IK,KN
	  CALL SPRSMLTCDOR(A,IA,JA,P,AP,N,NDIM,J)
          DOTN=CMPLX(0.0,0.0)
	  DOTD=0.0
          DO 280 I=1,N
           DOTN=DOTN+AMP(I)*CONJG(AP(I))
	   DOTD=DOTD+AP(I)*CONJG(AP(I))
 280     CONTINUE
        BETA(J)=-DOTN/DOTD
 300	CONTINUE
	DO 400 J=IK,KN
         DO 380 I=1,N
          P(I,KN+1)=BETA(J)*P(I,J)+P(I,KN+1)
 380	 CONTINUE
 400     CONTINUE
	DO 420 I=1,N
	  P(I,KN+1)=P(I,KN+1)+AR(I)
 420	CONTINUE
	DO 450 J=1,KN
	 DO 430 I=1,N
	  P(I,J)=P(I,J+1)
 430	 CONTINUE
 450	CONTINUE
 500     CONTINUE
 1002    FORMAT(/,1X,'DESIRED TOLERANCE....',1PE9.2,'  REACHED IN..',I5,
     &'  ITERATIONS')
 1001    FORMAT(/,1X,'DESIRED TOLERANCE..',1PE9.2,' NOT REACHED IN.',I5,
     &'  ITERATIONS')
        END
C
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE CDORTHOMINLD(A,X,R,TOL,IA,JA,ITMAX,N,KN,IP)
C
C THIS SUBROUTINE IS A LINEAR SYSTEM SOLVER USING ORTHOMIN(K) ALGORITHM
C WITH  DIAGONAL PRECONDITIONING FROM LEFT.
C SET PARAMETER K AS KN IN MAIN PROGRAM
C
         IMPLICIT DOUBLE PRECISION(A-H,O-Z)
         PARAMETER (NDIM=5000)
         PARAMETER (KMAX=11)
         DIMENSION JA(*),IA(*)
         COMPLEX*16 A(*),X(*),R(*)
	 COMPLEX*16 P(NDIM,KMAX),AMP(NDIM),AM(NDIM),AR(NDIM),V(NDIM)
	 COMPLEX*16 ALPHA,DOTN,BETA(KMAX)
         IF(KN.GE.KMAX) THEN
          WRITE(*,*) 'K OF ORTHOMIN(K) TOO LARGE'
          WRITE(*,*) 'MAXIMUM ALLOWED K IS',KMAX-1
          WRITE(*,*) 'ITERATION STOPPED'
          STOP
         END IF
         IF(NDIM.LT.N) THEN
          WRITE(*,*) 'INTERNAL SOLVER DIMENSIONS TOO SMALL'
          WRITE(*,*) 'CURRENT SETTING IS',NDIM
          WRITE(*,*) 'MUST BE GREATER OR EQUAL TO',N
          STOP
         END IF
         DO 2 I=1,N
          P(I,KN+1)=0.0
          P(I,KN)=R(I)
2        CONTINUE
         DO 4 K=1,KN-1
          DO 3 I=1,N
           P(I,K)=0.0
3         CONTINUE
4        CONTINUE
         DELTAOLD=0.0
         CALL DDIAG(A,AM,IA,JA,N)
         CALL SPRSMLTCD(A,IA,JA,X,R,N)
         DO 5 I=1,N
          R(I)=P(I,KN)-R(I)
5        CONTINUE
	 CALL DSOVMD(AM,R,N)
         DO 10 I=1,N
          P(I,KN)=R(I)
10       CONTINUE
         DO 500 K=1,ITMAX
	  IK=MIN(K,KN)
	  IK=KN-IK+1
	  CALL SPRSMLTCDOR(A,IA,JA,P,AMP,N,NDIM,KN)
	  CALL DSOVMD(AM,AMP,N) 
          DOTN=CMPLX(0.0,0.0)
          DOTD=0.0
          DO 100 I=1,N
            DOTN=DOTN+R(I)*CONJG(AMP(I))
            DOTD=DOTD+AMP(I)*CONJG(AMP(I))
100       CONTINUE
         ALPHA=DOTN/DOTD
         DO 200 I=1,N
          X(I)=X(I)+ALPHA*P(I,KN)
          R(I)=R(I)-ALPHA*AMP(I)
	  P(I,KN+1)=0
200      CONTINUE
         IF(K.GT.ITMAX) THEN
          WRITE(*,1001) TOL
          RETURN
         END IF
         DELTA=0.0
         DO 250 I=1,N
          DELTA=DELTA+R(I)*CONJG(R(I))
250      CONTINUE
         DELTA=SQRT(DELTA)/N
         IF(IP.EQ.1) WRITE(*,*) K,DELTA
         IF(DELTA.EQ.DELTAOLD) THEN
          WRITE(*,*) 'METHOD STALLED'
          WRITE(*,*) 'ITERATION STOPPED AT',K
          RETURN
         END IF
         DELTAOLD=DELTA
         IF(DELTA.LE.TOL) THEN
          WRITE(*,1002) TOL,K
          RETURN
         END IF
	  CALL SPRSMLTCD(A,IA,JA,R,AR,N)
	  CALL DSOVMD(AM,AR,N)
        DO 300 J=IK,KN
	 CALL SPRSMLTCDOR(A,IA,JA,P,AMP,N,NDIM,J)
	 CALL DSOVMD(AM,AMP,N)
	 DOTN=CMPLX(0.0,0.0)
	 DOTD=0.0
	 DO 280 I=1,N
          DOTN=DOTN+AR(I)*CONJG(AMP(I))
	  DOTD=DOTD+AMP(I)*CONJG(AMP(I))
280	 CONTINUE
        BETA(J)=-DOTN/DOTD
300     CONTINUE
	DO 400 J=IK,KN
         DO 380 I=1,N
          P(I,KN+1)=BETA(J)*P(I,J)+P(I,KN+1)
380	 CONTINUE
400     CONTINUE
	DO 420 I=1,N
	  P(I,KN+1)=P(I,KN+1)+R(I)
420	CONTINUE
	DO 450 J=1,KN
	 DO 430 I=1,N
	  P(I,J)=P(I,J+1)
430	 CONTINUE
450	CONTINUE
500     CONTINUE
1002    FORMAT(/,1X,'DESIRED TOLERANCE....',1PE9.2,'  REACHED IN..',I5,
     &'  ITERATIONS')
1001    FORMAT(/,1X,'DESIRED TOLERANCE..',1PE9.2,' NOT REACHED IN.',I5,
     &'  ITERATIONS')
        END
C
C*********************************************************************
C*********************************************************************
C
        SUBROUTINE CDORTHOMINRD(A,X,R,TOL,IA,JA,ITMAX,N,KN,IP)
C
C THIS SUBROUTINE IS A LINEAR SYSTEM SOLVER USING ORTHOMIN(K) ALGORITHM
C WITH  DIAGONAL PRECONDITIONING FROM RIGHT.
C SET PARAMETER K AS KN IN MAIN PROGRAM
C
         IMPLICIT DOUBLE PRECISION(A-H,O-Z)
         PARAMETER (NDIM=5000)
         PARAMETER (KMAX=11)
         DIMENSION JA(*),IA(*)
         COMPLEX*16 A(*),X(*),R(*) 
	 COMPLEX*16 P(NDIM,KMAX),AMP(NDIM),AM(NDIM),AR(NDIM),AP(NDIM)
	 COMPLEX*16 ALPHA,DOTN,BETA(KMAX)
         IF(KN.GE.KMAX) THEN
          WRITE(*,*) 'K OF ORTHOMIN(K) TOO LARGE'
          WRITE(*,*) 'MAXIMUM ALLOWED K IS',KMAX-1
          WRITE(*,*) 'ITERATION STOPPED'
          STOP
         END IF
         IF(NDIM.LT.N) THEN
          WRITE(*,*) 'INTERNAL SOLVER DIMENSIONS TOO SMALL'
          WRITE(*,*) 'CURRENT SETTING IS',NDIM
          WRITE(*,*) 'MUST BE GREATER OR EQUAL TO',N
          STOP
         END IF
         DO 2 I=1,N
          P(I,KN+1)=0.0
          P(I,KN)=R(I)
2        CONTINUE
         DO 4 K=1,KN-1
          DO 3 I=1,N
           P(I,K)=0.0
3         CONTINUE
4        CONTINUE
         DELTAOLD=0.0
         CALL DDIAG(A,AM,IA,JA,N)
         CALL SPRSMLTCD(A,IA,JA,X,R,N)
         DO 5 I=1,N
          R(I)=P(I,KN)-R(I)
	  AR(I)=R(I)
5        CONTINUE
	 CALL DSOVMD(AM,AR,N)
         DO 10 I=1,N
          P(I,KN)=AR(I)
10       CONTINUE
         DO 500 K=1,ITMAX
	  IK=MIN(K,KN)
	  IK=KN-IK+1
	  CALL SPRSMLTCDOR(A,IA,JA,P,AP,N,NDIM,KN)
          DOTN=CMPLX(0.0,0.0)
          DOTD=0.0
          DO 100 I=1,N
            DOTN=DOTN+R(I)*CONJG(AP(I))
            DOTD=DOTD+AP(I)*CONJG(AP(I))
100       CONTINUE
         ALPHA=DOTN/DOTD
         DO 200 I=1,N
          X(I)=X(I)+ALPHA*P(I,KN)
          R(I)=R(I)-ALPHA*AP(I)
	  AR(I)=R(I)
	  P(I,KN+1)=0
200      CONTINUE
         IF(K.GT.ITMAX) THEN
          WRITE(*,1001) TOL
          RETURN
         END IF
         DELTA=0.0
         DO 250 I=1,N
          DELTA=DELTA+R(I)*CONJG(R(I))
250      CONTINUE
         DELTA=SQRT(DELTA)/N
         IF(IP.EQ.1) WRITE(*,*) K,DELTA
         IF(DELTA.EQ.DELTAOLD) THEN
          WRITE(*,*) 'METHOD STALLED'
          WRITE(*,*) 'ITERATION STOPPED AT',K
          RETURN
         END IF
         DELTAOLD=DELTA
         IF(DELTA.LE.TOL) THEN
          WRITE(*,1002) TOL,K
          RETURN
         END IF
	  CALL DSOVMD(AM,AR,N)
	  CALL SPRSMLTCD(A,IA,JA,AR,AMP,N)
	DO 300 J=IK,KN
	  CALL SPRSMLTCDOR(A,IA,JA,P,AP,N,NDIM,J)
          DOTN=CMPLX(0.0,0.0)
	  DOTD=0.0
          DO 280 I=1,N
           DOTN=DOTN+AMP(I)*CONJG(AP(I))
	   DOTD=DOTD+AP(I)*CONJG(AP(I))
280     CONTINUE
        BETA(J)=-DOTN/DOTD
300	CONTINUE
	DO 400 J=IK,KN
         DO 380 I=1,N
          P(I,KN+1)=BETA(J)*P(I,J)+P(I,KN+1)
380	 CONTINUE
400     CONTINUE
	DO 420 I=1,N
	  P(I,KN+1)=P(I,KN+1)+AR(I)
420	CONTINUE
	DO 450 J=1,KN
	 DO 430 I=1,N
	  P(I,J)=P(I,J+1)
430	 CONTINUE
450	CONTINUE
500     CONTINUE
1002    FORMAT(/,1X,'DESIRED TOLERANCE....',1PE9.2,'  REACHED IN.',I5,
     &'  ITERATIONS')
1001    FORMAT(/,1X,'DESIRED TOLERANCE..',1PE9.2,' NOT REACHED IN.',I5,
     &'  ITERATIONS')
        END
C
C*********************************************************************
C*********************************************************************
C
	SUBROUTINE DSOVM (RA,IQ,JQ,D,N)
C
C THIS SUB. COMPUTE RA**(-1)*D
C IT IS CALLED BY THE CGS AND ORTHOMIN SOLVERS
C
C THIS SUBROUTINE CALCULATE MC=D. D IS KNOWN. C IS STORED IN D AT
C RETURN. M IS STORED IN RA AT INPUT.
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        COMPLEX*16 RA(*),D(*),S
	DIMENSION IQ(*),JQ(*)
C
	DO 30 I=1,N
	 S=CMPLX(0.0,0.0)
	 IF (I.EQ.1) THEN
	  II=1
	 ELSE
	  II=IQ(I-1)+1
	 END IF
	 DO 10 J=II,IQ(I)
	  IF (JQ(J).LT.I) THEN
	   S=S+RA(J)*D(JQ(J))
	  ELSE
	   GO TO 20
	  END IF
10	 CONTINUE
20	 D(I)=D(I)-S
30	CONTINUE
	KN=KAY(N,N,IQ,JQ)
	D(N)=D(N)/RA(KN)
	DO 60 I=N-1,1,-1
	 S=CMPLX(0.0,0.0)
	 II=KAY(I,I,IQ,JQ)+1
	 ID=II-1
	 DO 40 J=II,IQ(I)
	  S=S+RA(J)*D(JQ(J))
40	 CONTINUE
	 D(I)=(D(I)-S)/RA(ID)
60	CONTINUE
	RETURN
	END
C
C*********************************************************************
C*********************************************************************
C
	SUBROUTINE DSOVMD (RA,D,N)
C
C THIS SUBROUTINE CALCULATE MC=D. D IS KNOWN. C IS STORED IN D AT
C RETURN. M IS STORED IN RA AT INPUT.
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        COMPLEX*16 RA(*),D(*),S
C
	DO 30 I=1,N
	 S=RA(I)*D(I)
	 D(I)=S
 30	CONTINUE
	RETURN
	END
C
C*********************************************************************
C*********************************************************************
C
	SUBROUTINE DDIAG(RA,P,IQ,JQ,N)
C
C COMPUTES THE DIAGONAL PRECONDITIONING MATRIX FOR SOLVERS.  
C
C NON-ZERO ENTRIES OF A SPARSE MATRIX IS STORED IN A 1-D ARRAY RA AT INPUT.
C THE OUTPUT P=(DIAG(RA))**(-1)
C IQ(I) IS THE ADDRESS IN RA OF LAST NON-ZEARO ENTRY IN ROW I
C JQ(K) IS THE COLUMN INDEX IN A FOR RA(K)
C N IS THE ACTUAL NEMBER OF NODES
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        COMPLEX*16 RA(*),P(*),D
	DIMENSION IQ(*),JQ(*)
C
	DO 100 K=1,N
	 D=RA(KAY(K,K,IQ,JQ))
	 P(K)=D**(-1)
 100	CONTINUE
	RETURN 
	END
C
C*********************************************************************
C*********************************************************************
C
	SUBROUTINE PRECONCD(RA,IQ,JQ,N,MILU)
C
C THIS SUBROUTINE COMPUTE THE PRECONDITIONER M FOR C-G METHOD.
C THE ALGORITHM USED FOR DECOMPOSION OF M IS ILU OR MILU
C
C NON-ZERO ENTRIES OF A IS STORED IN A 1-D ARRAY RA AT INPUT.
C THE OUTPUT M OVERWRITE RA. IN WHICH L WILL OCCUPY THE LOWER
C HALF. U WILL OCCPY THE UPPER PART. L HAS UNIT DIAGNAL ENTRIES.
C IQ(I) IS THE ADDRESS IN RA OF LAST NON-ZEARO ENTRY IN ROW I
C JQ(K) IS THE COLUMN INDEX IN A FOR RA(K)
C N IS THE ACTUAL NEMBER OF NODES
C MILU IS TRUE WHEN DOING MILU, IS FALSE WHEN DOING ILU
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        COMPLEX*16 RA(*),E,D
	DIMENSION IQ(*),JQ(*)
	LOGICAL MILU
C
	DO 100 K=1,N-1
	 IRR=KAY(K,K,IQ,JQ)
	 D=RA(IRR)
	 DO 80 KQ1=IRR+1,IQ(K)
	  I=JQ(KQ1)
	  IR=KAY(I,K,IQ,JQ)
	  IF (RA(IR).NE.0) THEN
	   E=RA(IR)/D
	   RA(IR)=E
	   II=KAY(I,I,IQ,JQ)
	   DO 60 KQ2=IRR+1,IQ(K)
	    J=JQ(KQ2)
	    IF (RA(KQ2).NE.0) THEN
	     IJ=KAY(I,J,IQ,JQ)
	     IF (IJ.NE.0) THEN
	      RA(IJ)=RA(IJ)-E*RA(KQ2)
	     ELSE
	      IF (MILU) THEN
	       RA(II)=RA(II)-E*RA(KQ2)
	      END IF
	     END IF
	    END IF
60	   CONTINUE
	  ELSE
	   IF (IR.NE.0) THEN
	    RA(IR)=0
	   END IF
	  END IF
80	 CONTINUE
100	CONTINUE
	RETURN 
	END
C
C*********************************************************************
C*********************************************************************
C  END OF SPRSPAK
C  END OF SPRSPAK
C*********************************************************************
C*********************************************************************

