chapter xii, example 3. cubic spline interpolation with good knots
c  from  * a practical guide to splines *  by c. de boor
calls cubspl
      integer i,irate,istep,j,n,nhigh,nlow,nm1
      real algerp,aloger,c(4,20),decay,dx,errmax,g,h,pnatx,step,tau(20)
     *	  ,x
      data step, istep /20., 20/
      g(x) = sqrt(x+1.)
      decay = 0.
      read 500,irate,nlow,nhigh
  500 format(3i3)
      print 600
  600 format(28h  n   max.error   decay exp./)
      do 40 n=nlow,nhigh,2
	 nm1 = n-1
	 h = 1./float(nm1)
	 do 10 i=1,n
	    tau(i) = 2.*(float(i-1)*h)**irate - 1.
   10	    c(1,i) = g(tau(i))
c	 construct cubic spline interpolant.
	 call cubspl ( tau, c, n, 0, 0 )
c	 estimate max.interpolation error on (-1,1).
	 errmax = 0.
	 do 30 i=1,nm1
	    dx = (tau(i+1)-tau(i))/step
	    do 30 j=1,istep
	       h = float(j)*dx
	       pnatx = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.)
	       x = tau(i) + h
   30	       errmax = amax1(errmax,abs(g(x)-pnatx))
	 aloger = alog(errmax)
	 if (n .gt. nlow)  decay =
     *	     (aloger - algerp)/alog(float(n)/float(n-2))
	 algerp = aloger
   40	 print 640,n,errmax,decay
  640 format(i3,e12.4,f11.2)
					stop
      end


!                                       !
! build up the necessary combinatorics  !
!                                       !
 module maxnumden
  implicit none
  private
!                                       !
! the maximum number of denominators    !
! (it can be changed by the user)       !
!                                       !
  integer, public, parameter :: maxden= 8
 end module maxnumden
!
 module mbnvalues
  implicit none
  private
  integer, public, dimension(:,:,:), allocatable :: bn1
  integer, public, dimension(:,:,:), allocatable :: bn2
  integer, public, dimension(:,:,:), allocatable :: bn3
  integer, public, dimension(:,:,:), allocatable :: bn4
 end module mbnvalues
!
 module maxsolutions
  implicit none
  private
  integer, public :: max_solutions= 18
 end module maxsolutions
!
 module combinatorics
  use mbnvalues
  use maxnumden
  implicit none
  private
  integer, public, dimension(1:maxden) :: nbn1= -1
  integer, public, dimension(2:maxden) :: nbn2= -1
  integer, public, dimension(3:maxden) :: nbn3= -1
  integer, public, dimension(4:maxden) :: nbn4= -1
  public load_combinatorics
  contains
!
  subroutine load_combinatorics
  integer :: k,kden,ierr
  integer, parameter :: n1= 1,n2= 2,n3= 3,n4= 4
  integer :: k1,k2,k3,k4,kref,kcount,kc,kvalue
  if (maxden.ge.1) then
    do k= 1,maxden
     nbn1(k)= comb(k,n1)
    enddo
    ierr= -1
    allocate  (bn1(1:maxden,maxden,nbn1(maxden)), stat=ierr)
    if (ierr.ne.0) STOP "Not enough memory to allocate bn1"
    bn1= -1
    do kden= 1,maxden
     kcount= 0
     do k1= 1,kden
       kcount= kcount+1
       bn1(kden,1,kcount)= k1
       kref  = 0; kc    = 1
       do k= 1,kden
        if ((k.gt.kref).and.(k.ne.k1)) then
          kc= kc+1
          kref= k
          bn1(kden,kc,kcount)= k
        endif
       enddo
     enddo
    enddo
  endif
  if (maxden.ge.2) then
    do k= 2,maxden
     nbn2(k)= comb(k,n2)
    enddo
    ierr= -1
    allocate  (bn2(2:maxden,maxden,nbn2(maxden)), stat=ierr)
    if (ierr.ne.0) STOP "Not enough memory to allocate bn2"
    bn2= -1
    do kden= 2,maxden
     kcount= 0
     do k1= 1,kden; do k2= k1+1,kden
       kcount= kcount+1
       bn2(kden,1,kcount)= k1
       bn2(kden,2,kcount)= k2
       kref  = 0; kc    = 2
       do k= 1,kden
        if ((k.gt.kref).and.(k.ne.k1).and.(k.ne.k2)) then
          kc= kc+1
          kref= k
          bn2(kden,kc,kcount)= k
        endif
       enddo
     enddo; enddo
    enddo
  endif
  if (maxden.ge.3) then
    do k= 3,maxden
     nbn3(k)= comb(k,n3)
    enddo
    ierr= -1
    allocate  (bn3(3:maxden,maxden,nbn3(maxden)), stat=ierr)
    if (ierr.ne.0) STOP "Not enough memory to allocate bn3"
    bn3= -1
    do kden= 3,maxden
     kcount= 0
     do k1= 1,kden; do k2= k1+1,kden; do k3= k2+1,kden
       kcount= kcount+1
       bn3(kden,1,kcount)= k1
       bn3(kden,2,kcount)= k2
       bn3(kden,3,kcount)= k3
       kref  = 0; kc    = 3
       do k= 1,kden
        if ((k.gt.kref).and.(k.ne.k1).and.(k.ne.k2).and.(k.ne.k3)) then
          kc= kc+1
          kref= k
          bn3(kden,kc,kcount)= k
        endif
       enddo
     enddo; enddo; enddo
    enddo
  endif
  if (maxden.ge.4) then
    do k= 4,maxden
     nbn4(k)= comb(k,n4)
    enddo
    ierr= -1
    allocate  (bn4(4:maxden,maxden,nbn4(maxden)), stat=ierr)
    if (ierr.ne.0) STOP "Not enough memory to allocate bn4"
    bn4= -1
    do kden= 4,maxden
     kcount= 0
     do k1= 1,kden; do k2= k1+1,kden; do k3= k2+1,kden; do k4= k3+1,kden
       kcount= kcount+1
       bn4(kden,1,kcount)= k1
       bn4(kden,2,kcount)= k2
       bn4(kden,3,kcount)= k3
       bn4(kden,4,kcount)= k4
       kref  = 0; kc    = 4
       do k= 1,kden
        if ((k.gt.kref).and.(k.ne.k1).and.(k.ne.k2) &
           .and.(k.ne.k3).and.(k.ne.k4)) then
          kc= kc+1
          kref= k
          bn4(kden,kc,kcount)= k
        endif
       enddo
     enddo; enddo; enddo; enddo
    enddo
  endif
  end subroutine load_combinatorics
!
  integer function comb(no,ko)
  integer, intent(in) :: no,ko
  integer, dimension(1:4), parameter :: ifact= (/1,2,6,24/)
  integer :: k,kf
  if ((ko.le.0).or.(ko.gt.4)) then
   stop 'error in function comb'
  endif
  kf= no
  do k= 1,(ko-1)
   kf= kf*(no-k)
  enddo
  kf= kf/ifact(ko)
  comb= kf
  end function comb
!
  subroutine testcomb(np)
  integer, intent(in) :: np
  integer :: ib,j
  call load_combinatorics
!
! D sector:
!
  print*,'          '
  print*,' D-sector:'
  print*,'          '
  do ib= 1,nbn4(np)
    print*,'         ib=',ib
    do j= 1,np
      print*,'bn4(np,',j,',ib)=',bn4(np,j,ib)
    enddo
  enddo
!
! C sector:
!
  print*,'          '
  print*,' C-sector:'
  print*,'          '
  do ib= 1,nbn3(np)
    print*,'         ib=',ib
    do j= 1,np
      print*,'bn3(np,',j,',ib)=',bn3(np,j,ib)
    enddo
  enddo
!
! B sector:
!
  print*,'          '
  print*,' B-sector:'
  print*,'          '
  do ib= 1,nbn2(np)
    print*,'         ib=',ib
    do j= 1,np
      print*,'bn2(np,',j,',ib)=',bn2(np,j,ib)
    enddo
  enddo
!
! A sector:
!
  print*,'          '
  print*,' A-sector:'
  print*,'          '
  do ib= 1,nbn1(np)
    print*,'         ib=',ib
    do j= 1,np
      print*,'bn1(np,',j,',ib)=',bn1(np,j,ib)
    enddo
  enddo
  end subroutine testcomb
 end module combinatorics
!
 module dimensions
  use combinatorics
  use mbnvalues
  implicit none
  private
  integer, public :: dmns,dmns_d,dmns_c,dmns_b,dmns_a
  integer, public :: dmns_4,dmns_3,dmns_2,dmns_1
  integer, public, dimension(:,:), allocatable :: bbn1
  integer, public, dimension(:,:), allocatable :: bbn2
  integer, public, dimension(:,:), allocatable :: bbn3
  integer, public, dimension(:,:), allocatable :: bbn4
  public load_dimensions
  contains
!
  subroutine load_dimensions
  use maxnumden
  dmns  = maxden
  dmns_a= nbn1(dmns)
  dmns_b= nbn2(dmns)
  dmns_c= nbn3(dmns)
  dmns_d= nbn4(dmns)
  end subroutine
 end module dimensions


c
c**********************
c
        subroutine anfld(x,n,kmx,b,c,a,y)

        complex x(kmx,2),y(n),b(n,2),c(2),a(2),wrk(2,2)

c       this routine takes i complex n-vectors (x) and transforms them
c       to the output complex n-vector (y) which satisfies the i linear
c       constraints   <y,b(i)> = c(i); a contains the coefficients of the
c       representation of y in terms of the x's

c       special case i = 2

        i = 2

        do 10 ii=1,i
        do 10 jj=1,i
        wrk(ii,jj)=(0.0,0.0)

           do 5 kk=1,n
           wrk(ii,jj)=wrk(ii,jj)+x(kk,jj)*b(kk,ii)
5          continue
10      continue

        call cinv2(wrk)

        call cmmult(wrk,c,a,2,2,1)

        do 15 in=1,n
        y(in)=(0.0,0.0)

           do 15 ii=1,i
           y(in)=y(in)+a(ii)*x(in,ii)
15      continue

        return
        end
c______________________________________________________________________
c
      subroutine mkbih(b,nt,ih,ie,nsta,ista)

      complex b(nt,2)
      integer ih(*),ie(*)

      if(ista.ge.1) then
c       use station ISTA as "normal"
         do j = 1,nt
            do k = 1,2
               b(j,k) = (0.,0.)
            enddo
         enddo
         b(ih(ista),1) = (1.,0.)
         b(ih(ista)+1,2) = (1.,0.)
      else
c        use average as normal
         do j = 1,nt
            do k = 1,2
               b(j,k) = (0.,0.)
            enddo
         enddo
         rn = 0.
         do i = 1,nsta
            if(ih(i)+1 .lt. ie(i)) then
               b(ih(i),1) = cmplx(1.,0.)
               b(ih(i)+1,2) = cmplx(1.,0.)
               rn = rn+1.
            endif
         enddo
         do i = 1,nt
            do k = 1,2
               b(i,k) = b(i,k)/rn
            enddo
         enddo
      end if

      return
      end
ccc_____________________________________________________________________
ccc
      subroutine pw_err(a,sig_r,sig_ref,nsta,nt,ih,res_diag,pw,iref,
     &    pw_se)
      complex a(2,2),sig_r(2,2,*),ac(2),temp(2),pw(nt,2),sig_ref(2,2),
     &    temp1
      integer ih(*),iref,nt
      real res_diag(*),pw_se(nt,2),err_ref(2)

      do k = 1,2
         ac(1) = conjg(a(1,k))
         ac(2) = conjg(a(2,k))
         do ista = 1,nsta
           call cmmult(sig_r(1,1,ista),ac,temp,2,2,1)
           err = real(temp(1)*a(1,k)+temp(2)*a(2,k))
           if(ista.eq.iref) err_ref(k) = err
           do i = ih(ista),ih(ista+1)-1
              pw_se(i,k) = res_diag(i)*err
           enddo
         enddo
      enddo

      if(iref .gt. 0 )then
ccc      propogate error in reference component into other components
         do i = 1,nt
            if((i.ne.ih(iref)) .and.(i.ne.ih(iref)+1)) then
                temp(1) = pw(i,1)
                temp(2) = pw(i,2)
                call cmmult(sig_ref,temp,ac,2,2,1)
                ac(1) = conjg(ac(1))
                ac(2) = conjg(ac(2))
                call cmmult(temp,ac,temp1,1,2,1)
                do k = 1,2
                   pw_se(i,k) = pw_se(i,k) + real(temp1)*err_ref(k)
                enddo
            else
                do k = 1,2
                   pw_se(i,k) = 0.0
                enddo
            endif
         enddo
      endif
      do i = 1,nt
         do k = 1,2
            pw_se(i,k) = sqrt(pw_se(i,k))
         enddo
      enddo
      return
      end


      PROGRAM VVEX01
C
C This example overlays vectors on a polar contour plot using
C data generated with a randomizing algorithm. The first frame colors
C the vectors according to the data used to generate the contour plot,
C with the result that the color of the vectors corresponds to the
C contour level at each location. In the second frame the vectors
C are colored by magnitude.
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C The contour, vector field component, and area map array declarations:
C
      PARAMETER (MSIZE=33, NSIZE=33)
      PARAMETER (LAMA=25000)
      DIMENSION ZDAT(MSIZE,NSIZE)
      DIMENSION U(60,60), V(60,60)
      DIMENSION IAMA(LAMA)
C
C Workspace arrays for Conpack:
C
      DIMENSION RWRK(5000),IWRK(1000)
C
C ARSCAM arrays:
C
      DIMENSION XCRA(1000),YCRA(1000)
      DIMENSION IARA(10),IGRA(10)
C
C Declare the masked rendering routines for drawing and shading the
C contour plot, as well as for drawing the vectors
C
      EXTERNAL DRAWCL
      EXTERNAL SHADER
      EXTERNAL VVUDMV
C
      DATA U / 3600 * 0.0 /
C
C Initialization
C ==================================================================
C Open GKS.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
      CALL GSCLIP (0)
C
C Generate a scalar data array, then create a special value region
C
      CALL GENDAT (ZDAT,MSIZE,MSIZE,NSIZE,20,20,-1.,1.)
C
      DO 102 I=1,MSIZE
         DO 101 J=1,NSIZE
            IF (REAL(I-20)**2+REAL(J-10)**2.LT.25) ZDAT(I,J)=1.E36
 101     CONTINUE
 102  CONTINUE
C
C Subroutine GENARA generates smoothly varying random data in its
C second array argument based upon the contents of the first. Call it
C twice to randomize both the U and V vector component data arrays.
C Then set up the color table.
C
      CALL GENARA(U,V,60,60)
      CALL GENARA(V,U,60,60)
      CALL DFCLRS(IWKID)
C
C Conpack setup:
C ===============================================================
C Set up a polar coordinate system mapping for Conpack
C
      CALL SET    (0.05,0.95,0.05,0.95,-1.0,1.0,-1.0,1.0,1)
      CALL CPSETI ('MAP - Mapping Function',2)
      CALL CPSETI ('SET - Do-Set-Call Flag',0)
      CALL CPSETR ('XC1 - Rho At I = 1',.1)
      CALL CPSETR ('XCM - Rho At I = M',1.)
      CALL CPSETR ('YC1 - Theta At J = 1',0.0)
      CALL CPSETR ('YCN - Theta At J = N',360.0)
C
C Enable special value processing and outline special value regions
C
      CALL CPSETR ('SPV - Special Value',1.E36)
      CALL CPSETI ('PAI - Parameter Array Index',-2)
      CALL CPSETI ('CLU - Contour Level Use Flag',1)
      CALL CPSETR ('CLL - Contour Level Line Width',2.)
C
C Adjust Conpack labelling and outline the data field.
C
      CALL CPSETI ('LLP - Line Label Positioning',3)
      CALL CPSETI ('RWC - Real Workspace For Contours',200)
      CALL CPSETI ('HLB - High/Low Label Box Flag',1)
      CALL CPSETI ('HLO - High/Low Label Overlap Flag',11)
      CALL CPSETR ('CWM - Character Width Multiplier',1.25)
      CALL CPSETI ('PAI - Parameter Array Index',-1)
      CALL CPSETI ('CLU - Contour Level Use Flag',1)
      CALL CPSETR ('CLL - Contour Level Line Width',2.)
C
C Initialize the drawing of the contour plot, and tell Conpack
C to pick the contour levels.
C
      CALL CPRECT (ZDAT,MSIZE,MSIZE,NSIZE,RWRK,5000,IWRK,1000)
      CALL CPPKCL (ZDAT,RWRK,IWRK)
C
C Set the attributes of the contour lines
C
      CALL CPGETI ('NCL - Number Of Contour Levels',NCLV)
      DO 107 ICLV=1,NCLV
         CALL CPSETI ('PAI - Parameter Array Index',ICLV)
         CALL CPGETI ('CLU - Contour Level Use Flag',ICLU)
         IF (ICLU.EQ.3) THEN
            CALL CPSETI ('CLL - Contour-Line Line Width',2)
         END IF
         CALL CPSETI ('AIA - Area Identifier Above Level',0)
         CALL CPSETI ('AIB - Area Identifier Below Level',0)
 107  CONTINUE
C
C Add two new levels for which no contour lines are to be drawn, but
C between which shading is to be done.
C
      NCLV=NCLV+2
      CALL CPSETI ('NCL - Number Of Contour Levels',NCLV)
      CALL CPSETI ('PAI - Parameter Array Index',NCLV-1)
      CALL CPSETR ('CLV - Contour Level Value',-.15)
      CALL CPSETI ('CLU - Contour Level Use Flag',0)
      CALL CPSETI ('AIA - Area Identifier Above Level',1)
      CALL CPSETI ('AIB - Area Identifier Below Level',2)
      CALL CPSETI ('PAI - Parameter Array Index',NCLV)
      CALL CPSETR ('CLV - Contour Level Value',+.15)
      CALL CPSETI ('CLU - Contour Level Use Flag',0)
      CALL CPSETI ('AIA - Area Identifier Above Level',3)
      CALL CPSETI ('AIB - Area Identifier Below Level',1)
C
C Initialize the area map and draw the contour labels into it.
C
      CALL ARINAM (IAMA,LAMA)
      CALL CPLBAM (ZDAT,RWRK,IWRK,IAMA)
C
C Vectors setup:
C ==================================================================
C Set the mapping flag for the polar transformation.
C Set the X,Y array index mapping parameters to the same values used
C bythe Conpack CPSET routines above. Turn on masking and turn the
C Set call flag off.
C
      CALL VVSETI('MAP -- Mapping Flag', 2)
      CALL VVSETI('SET -- Set Call Flag', 0)
      CALL VVSETR('XC1 -- Lower X Bound', 0.1)
      CALL VVSETR('XCM -- Upper X Bound', 1.0)
      CALL VVSETR('YC1 -- Lower X Bound', 0.0)
      CALL VVSETR('YCN -- Upper Y Bound', 360.0)
      CALL VVSETI('MSK -- Area Mask Flag', 1)
C
C Enable special value processing for the P array to eliminate
C vectors from the special value region. This is not really required
C in this case since the masking routine eliminates these vectors.
C
      CALL VVSETI('SPC -- P Special Value Color', 0)
      CALL VVSETR('PSV -- P Special Value', 1.E36)
C
C Enable vector coloring
C
      CALL VVSETI('NLV - Number of Levels', 14)
      DO 800 I=1,14,1
         CALL VVSETI('PAI -- Parameter Array Index', I)
         CALL VVSETI('CLR -- GKS Color Index', I+1)
 800  CONTINUE
C
C Set up miscellaneous attribute parameters
C
      CALL VVSETR('LWD -- Vector Linewidth', 2.0)
      CALL VVSETR('AMN -- Arrow Minimum Size', 0.01)
      CALL VVSETI('VPO -- Vector Position Method', 0)
      CALL VVSETI('XIN - X Grid Increment', 2)
C
C Move the minimum and maximum vector text blocks out of the
C way of the text that Conpack puts out.
C
      CALL VVSETR('MNX - Minimum Vector X Pos', 0.0)
      CALL VVSETR('MXX - Maximum Vector X Pos', 0.33)
      CALL VVSETI('MNP - Minimum Vector Justification', 2)
      CALL VVSETI('MXP - Maximum Vector Justification', 4)
C
C Turn on statistics
C
      CALL VVSETI('VST - Vector statistics', 1)
C
C Drawing loop
C ===================================================================
C Draw the contour plot with vectors overlaid twice. In the first
C plot Vectors uses the same data as Conpack for the independent
C scalar array. Therefore the colors of the vectors correspond to the
C contours. The second plot shows the vectors colored by magnitude.
C
      DO 2000 K=1,2
C
C First draw masked contour lines, then labels, then put the
C contour lines in the area map for shading by ARSCAM
C
         CALL CPCLDM (ZDAT,RWRK,IWRK,IAMA,DRAWCL)
         CALL CPLBDR (ZDAT,RWRK,IWRK)
         CALL CPCLAM (ZDAT,RWRK,IWRK,IAMA)
         CALL ARSCAM (IAMA,XCRA,YCRA,1000,IARA,IGRA,10,SHADER)
C
C Choose between vector magnitude and scalar array coloring
C
         IF (K .EQ. 1) THEN
            CALL VVSETI('CTV -- Color Threshold Value', 2)
         ELSE
            CALL VVSETI('CTV -- Color Threshold Value', 1)
         END IF
C
C Initialize Vectors
C
         CALL VVINIT (U,60,V,60,ZDAT,MSIZE,MSIZE,NSIZE,0,0)
C
C Remove the bottom 05% of the vectors
C
         CALL VVGETR('VMX -- Max Vector Magnitude',VMX)
         CALL VVGETR('VMN -- Min Vector Magnitude',VMN)
         CALL VVSETR('VLC -- Vector Low Cutoff',
     +        VMN+0.05*(VMX-VMN))
C
C Increase the size of the longest vector by 50% from its default
C value and make the shortest one fourth the length of the longest.
C
         CALL VVGETR('DMX -- Max Vector Device Magnitude',DMX)
         CALL GETSET(VL,VR,VB,VT,UL,UR,UB,UT,LL)
         VRL = 1.5 * DMX / (VR - VL)
         CALL VVSETR('VRL - Vector Realized Length', VRL)
         CALL VVSETR('VFR -- Vector Fractional Minimum', 0.25)
C
C Call VVECTR to draw the vectors, using the same area map that
C the Conpack routines used. The 'Draw Masked Vector' routine
C used is the one supplied with the Velocity Vector Utility.
C
         CALL VVECTR (U,V,ZDAT,IAMA,VVUDMV,0)
C
C Put a boundary line at the edge of the plotter frame.
C
         CALL BNDARY
C
C Advance the frame.
C
         CALL FRAME
C
 2000 CONTINUE
C
C Close GKS.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
C
C Done.
C
      STOP
C
      END
C
      SUBROUTINE DRAWCL (XCS,YCS,NCS,IAI,IAG,NAI)
C
C This version of DRAWCL draws the polyline defined by the points
C ((XCS(I),YCS(I)),I=1,NCS) if and only if none of the area identifiers
C for the area containing the polyline are negative.  The dash package
C routine CURVED is called to do the drawing.
C
      DIMENSION XCS(*),YCS(*),IAI(*),IAG(*)
C
C Turn on drawing.
C
      IDR=1
C
C If any area identifier is negative, turn off drawing.
C
      DO 101 I=1,NAI
         IF (IAI(I).LT.0) IDR=0
 101  CONTINUE
C
C If drawing is turned on, draw the polyline.
C
      IF (IDR.NE.0) CALL CURVED (XCS,YCS,NCS)
C
C Done.
C
      RETURN
C
      END
C
      SUBROUTINE SHADER (XCS,YCS,NCS,IAI,IAG,NAI)
C
C This version of SHADER shades the polygon whose edge is defined by
C the points ((XCS(I),YCS(I)),I=1,NCS) if and only, relative to edge
C group 3, its area identifier is a 1.  The package SOFTFILL is used
C to do the shading.
C
      DIMENSION XCS(*),YCS(*),IAI(*),IAG(*)
C
C Define workspaces for the shading routine.
C
      DIMENSION DST(1100),IND(1200)
C
C Turn off shading.
C
      ISH=0
C
C If the area identifier for group 3 is a 1, turn on shading.
C
      DO 101 I=1,NAI
         IF (IAG(I).EQ.3.AND.IAI(I).EQ.1) ISH=1
 101  CONTINUE
C
C If shading is turned on, shade the area.  The last point of the
C edge is redundant and may be omitted.
C
      IF (ISH.NE.0) THEN
         CALL SFSETI ('ANGLE',45)
         CALL SFSETR ('SPACING',.006)
         CALL SFWRLD (XCS,YCS,NCS-1,DST,1100,IND,1200)
         CALL SFSETI ('ANGLE',135)
         CALL SFNORM (XCS,YCS,NCS-1,DST,1100,IND,1200)
      END IF
C
C Done.
C
      RETURN
C
      END


! MODULE: pf_my_sweeper_ad
! !> @author
!> Tommaso Buvoli
!
! Last Modified: Dec 28, 2018
!
! Description!
! Exponential Sweeper for 1-D advection/diffusion example: u_t + v*u_x = nu*u_xx

module pf_my_sweeper
  use pf_mod_dtype
  use pf_mod_ndarray
  use pf_mod_exp_sweeper
  use phi_mod
  use pf_mod_fftpackage
  implicit none

  !>  extend the exponential sweeper
  type, extends(pf_exp_t) :: ad_sweeper_t
     integer ::     nx
     ! phi storage and scratch space
     complex(pfdp), allocatable :: phi(:,:)
     complex(pfdp), allocatable :: swp_phi(:,:,:)
     complex(pfdp), allocatable :: res_phi(:,:,:)
     complex(pfdp), allocatable :: yhat(:) ! used in applyPhi to store Fourier transform of final result
     complex(pfdp), allocatable :: bhat(:) ! used in applyPhi to store Fourier transform of final result
     real(pfdp) :: h_swpPhi = real(0.0, pfdp)
     real(pfdp) :: h_resPhi = real(0.0, pfdp)
     ! fft object and differentiaton matrices
     type(pf_fft_t), pointer :: fft_tool
     complex(pfdp), allocatable :: lap(:) ! Laplacian operators
     complex(pfdp), allocatable :: ddx(:) ! First derivative operators

   contains

     procedure :: f_eval       !  Computes the advection and diffusion terms
     procedure :: phib         !  Computes phi functions
     procedure :: swpPhib      !  Computes phi functions
     procedure :: resPhib      !  Computes phi functions
     procedure, private :: storePhi
     procedure, private :: applyPhi
     procedure :: initialize
     procedure :: destroy
  end type ad_sweeper_t

contains

    !>  Helper function to return sweeper pointer
    function as_ad_sweeper(sweeper) result(r)
        class(pf_sweeper_t), intent(inout), target :: sweeper
        class(ad_sweeper_t), pointer :: r
        select type(sweeper)
        type is (ad_sweeper_t)
        r => sweeper
        class default
        stop
        end select
    end function as_ad_sweeper

    !>  Routine to set up sweeper variables and operators
    subroutine initialize(this, pf,level_index)
      class(ad_sweeper_t), intent(inout) :: this
      type(pf_pfasst_t),   intent(inout),target :: pf
      integer, intent(in) :: level_index

      integer ::  nx,nnodes
      class(pf_level_t), pointer :: lev

      lev => pf%levels(level_index)
      this%nx=lev%lev_shape(1)
      nx=this%nx
      nnodes=lev%nnodes

      ! call superclass initialize
      call this%exp_initialize(pf,level_index)

      ! Decide if phi will be recomputed
      this%use_phib=.true.   !  False means they will not be recomputed

      ! allocate space for phi functions
      allocate(this%phi(lev%nnodes+1, nx))
      allocate(this%swp_phi(lev%nnodes - 1, lev%nnodes+1, nx))
      allocate(this%res_phi(lev%nnodes - 1, lev%nnodes+1, nx))
      allocate(this%yhat(nx))
      allocate(this%bhat(nx))

      ! allocate fft & differentiation matrices
      allocate(this%fft_tool)
      call this%fft_tool%fft_setup([nx],1)
      allocate(this%lap(nx))
      allocate(this%ddx(nx))
      call this%fft_tool%make_lap(this%lap)
      call this%fft_tool%make_deriv(this%ddx)
    end subroutine initialize

     ! DESTROY: calls superclass destroy and deallocates all array type parameters
     subroutine destroy(this,pf,level_index)
       class(ad_sweeper_t), intent(inout) :: this
       type(pf_pfasst_t),   intent(inout),target :: pf
       integer,             intent(in)    :: level_index

       call this%exp_destroy(pf,level_index)

       ! deallocate arrays
       deallocate(this%phi)
       deallocate(this%swp_phi)
       deallocate(this%res_phi)
       deallocate(this%lap)
       deallocate(this%ddx)
       deallocate(this%yhat)
       deallocate(this%bhat)
       call this%fft_tool%fft_destroy()
       deallocate(this%fft_tool)

    end subroutine destroy

  ! ==================================================================
  ! Required subroutines for any sweeper that inherits from pf_exp_t
  ! ==================================================================

     !F_EVAL: evaluates the nonlinear function N(t,y(t)) at y, t.
     subroutine f_eval(this, y, t, level_index, n)
        use probin, only:  splitting, v,nu

        ! arguments
        class(ad_sweeper_t), intent(inout) :: this
        class(pf_encap_t),   intent(in)    :: y
        real(pfdp),          intent(in)    :: t
        integer,             intent(in)    :: level_index
        class(pf_encap_t),   intent(inout) :: n

        ! local variables
        real(pfdp),         pointer :: yvec(:), nvec(:)
        type(pf_fft_t),     pointer :: fft

        yvec  => get_array1d(y)
        nvec  => get_array1d(n)
        fft   => this%fft_tool

        select case (splitting)
            case (1) ! u_xx exponential, u_x explicit
                call fft%conv(yvec,-v * this%ddx,nvec)
            case (2) ! Fully Exponential
                call n%setval(real(0.0, pfdp))
            case (3) ! u_x exponential, u_xx explicit
                call fft%conv(yvec,nu * this%lap,nvec)
        end select

     end subroutine f_eval

     ! PHIB: compute phi products without storing result (useful for variable timestepping)
     subroutine phib(this, t, h, b, y)
         use probin, only: nu, v, splitting
         ! arguments
         class(ad_sweeper_t), intent(inout) :: this
         real(pfdp),          intent(in)    :: t
         real(pfdp),          intent(in)    :: h
         class(pf_encap_t),   intent(in)    :: b(:)
         class(pf_encap_t),   intent(inout) :: y

         select case (splitting)
             case (1)
                 call phi(t * h * (nu * this%lap), size(b) - 1, this%phi) ! initialize phi
             case (2)
                 call phi(t * h * (nu * this%lap - v * this%ddx), size(b) - 1, this%phi) ! initialize phi
             case (3)
                 call phi(t * h * (- v * this%ddx), size(b) - 1, this%phi) ! initialize phi
         end select

         call this%applyPhi(t, h, this%phi, b, y)      ! compute phi products

     end subroutine phib

     ! SWPPHIB: compute phi products for sweeper and stores result
     subroutine swpPhib(this, j, h, b, y)

         ! arguments
         class(ad_sweeper_t), intent(inout) :: this
         integer,             intent(in)    :: j
         real(pfdp),          intent(in)    :: h
         class(pf_encap_t),   intent(in)    :: b(:)
         class(pf_encap_t),   intent(inout) :: y

         ! compute and store phi
         if(h .NE. this%h_swpPhi) then
             call storePhi(this, this%eta, h, this%swp_phi)
             this%h_swpPhi = h
         end if

         ! compute phi products
         call this%applyPhi(this%eta(j), h, this%swp_phi(j,:,:), b, y)

     end subroutine swpPhib

     ! RESPHIB: compute phi products for residual computation and stores result
     subroutine resPhib(this, j, h, b, y)

          ! arguments
          class(ad_sweeper_t), intent(inout) :: this
          integer,             intent(in)    :: j
          real(pfdp),          intent(in)    :: h
          class(pf_encap_t),   intent(in)    :: b(:)
          class(pf_encap_t),   intent(inout) :: y

          ! compute and store phi
          if(h .NE. this%h_resPhi) then
              call storePhi(this, this%nodes(2:size(this%nodes)), h, this%res_phi)
              this%h_resPhi = h
          end if

          ! compute phi products
          call this%applyPhi(this%nodes(j+1), h, this%res_phi(j,:,:), b, y)

      end subroutine resPhib

  ! ==================================================================
  ! helper subroutines for resPhib and swpPhib
  ! ==================================================================

      ! STOREPHI: computes and stores phi functions phi_j(t(i) h L)
      subroutine storePhi(this, ts, h, phi_storage)

          use probin, only: nu, v, splitting
          ! arguments
          class(ad_sweeper_t), intent(inout) :: this
          real(pfdp), intent(in)  :: ts(:)
          real(pfdp), intent(in)  :: h
          complex(pfdp), intent(out) :: phi_storage(:,:,:)
          ! local variables
          integer :: i, n, m

          m = size(ts)         ! number of t to compute
          n = size(this%nodes) ! highest order phi function
          do i = 1, m
             select case (splitting)
                 case (1)
                     call phi_zvector(ts(i) * h * (nu * this%lap), n, phi_storage(i,:,:)) ! initialize phi
                 case (2)
                     call phi_zvector(ts(i) * h * (nu * this%lap - v * this%ddx), n, phi_storage(i,:,:)) ! initialize phi
                 case (3)
                     call phi_zvector(ts(i) * h * (- v * this%ddx), n, phi_storage(i,:,:)) ! initialize phi
             end select
          end do

      end subroutine storePhi

      ! APPLYPHI: compute phi_0(t h L ) b_1 + h \sum_{i = 1} phi_i(t h L) b_i
      subroutine applyPhi(this, t, h, phis, b, y)

          ! arguments
          class(ad_sweeper_t), intent(inout) :: this
          real(pfdp),          intent(in)    :: t
          real(pfdp),          intent(in)    :: h
          complex(pfdp),       intent(in)    :: phis(:,:)
          class(pf_encap_t),   intent(in)    :: b(:)
          class(pf_encap_t),   intent(inout) :: y
          ! local variables
          integer :: i, n
          real(pfdp), pointer :: bvec(:), yvec(:)
          type(pf_fft_t),     pointer :: fft

          n = size(b)
          yvec => get_array1d(y)

          ! prepare fft variables
          fft    => this%fft_tool

          this%yhat = CMPLX(0.0, 0.0, pfdp)
          do i = 1, n
             bvec => get_array1d(b(i))

             call fft%fft(bvec,this%bhat)
             if(i .eq. 1) then
                 this%yhat = phis(1,:) * this%bhat                              ! phi_0(hL) b(1)           [no h factor]
             else
                this%yhat =this%yhat+  t**(i-1) * h * phis(i,:) * this%bhat   ! t^{n-1} phi_i(hL) h b(n) [h factor included]
             end if
         end do
         call fft%ifft(this%yhat,yvec)

      end subroutine applyPhi

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!>  Here are some extra routines which are problem dependent
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Routine to set initial condition.
  subroutine initial(y_0)
    type(pf_ndarray_t), intent(inout) :: y_0
    call exact(0.0_pfdp, y_0%flatarray)
  end subroutine initial

  !> Routine to return the exact solution
  subroutine exact(t, yex)
    use probin, only: nprob,nu, v, t00, kfreq
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(out) :: yex(:)

    integer    :: nx, i, ii, k,nbox
    real(pfdp) :: tol, x, t0,Dx, omega

    nx = size(yex)
    Dx = 1.0d0/dble(nx)

    if (nprob .eq. 1) then
       !  Using sin wave initial condition
       omega = two_pi*kfreq
       do i = 1, nx
          x = dble(i-1-nx/2)/dble(nx) - t*v
          yex(i) = cos(omega*x)*exp(-omega*omega*nu*t)
       end do
    else  !  Use periodic image of Gaussians
       yex=0
       if (nu .gt. 0.0) then
          nbox = ceiling(sqrt(4.0*nu*(t00+t)*37.0d0))  !  Decide how many periodic images
          do k = -nbox,nbox
             do i = 1, nx
                x = dble(i-1-nx/2)/dble(nx) - t*v + dble(k)
                yex(i) = yex(i) + sqrt(t00)/sqrt(t00+t)*exp(-x*x/(4.0*nu*(t00+t)))
             end do
          end do
       else
          nbox = ceiling(sqrt(37.0d0))  !  Decide how many periodic images
          do k = -nbox,nbox
             do i = 1, nx
                x = dble(i-1-nx/2)/dble(nx) - t*v  + dble(k)
                yex(i) = yex(i) + exp(-x*x)
             end do
          end do
       end if  ! nbox

    end if
  end subroutine exact

end module pf_my_sweeper


module mult_mod
    implicit none
    public :: mult

    interface mult
        procedure mult_real, mult_int
    end interface mult

contains
    real function mult_real(n1, n2) result(product)
        real, intent(in) :: n1, n2
        product = n1 * n2
    end function mult_real

    integer function mult_int(n1, n2) result(product)
        integer, intent(in) :: n1, n2
        product = n1 * n2
    end function mult_int

end module mult_mod


*
*     ------------------------------------------------------------------
*	P A M T M T
*     ------------------------------------------------------------------
*
      SUBROUTINE PAMTMT(X,T,WORK,NORB)
*
* GENERATE PER AKE'S T MATRIX FROM A
* ORBITAL ROTATION MATRIX X
*
* T IS OBTAINED AS A STRICTLY LOWER TRIANGULAR
* MATRIX TL AND AN UPPER TRIANGULAR MATRIX TU
*
*         TL = 1 - L
*         TU = U ** -1
*
* WHERE L AND U ARISES FROM A LU DECOMPOSITION OF
* X :
*         X = L * U
* WITH L BEING A LOWER TRIANGULAR MATRIX WITH UNIT ON THE
* DIAGONAL AND U IS AN UPPER TRIANGULAR MATRIX
*
* JEPPE OLSEN OCTOBER 1988
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION X(NORB,NORB),T(NORB,NORB)
      DIMENSION WORK(*)
* DIMENSION OF WORK : NORB ** 2 + NORB*(NORB+1) / 2
*
      NTEST = 0
*. Allocate local memory
      KLFREE = 1
C     KLL = KFLREE
      KLL = KLFREE
      KLFREE = KLL + NORB*(NORB+1)/2
      KLU = KLFREE
      KLFREE = KLU + NORB ** 2
*.LU factorize X
      CALL LULU(X,WORK(KLL),WORK(KLU),NORB)
*.Expand U to full matrix
      CALL SETVEC(T,0.0D0,NORB ** 2 )
      DO 10 I = 1,NORB
      DO 10 J = I,NORB
        T(I,J) = WORK(KLU-1+J*(J-1)/2+I)
   10 CONTINUE
      IF ( NTEST .GE. 10 ) THEN
        WRITE(6,*) ' MATRIX TO BE INVERTED '
        CALL WRTMAT(T,NORB,NORB,NORB,NORB)
      END IF
*.Invert U
      CALL INVMAT(T,WORK(KLU),NORB,NORB)
      IF ( NTEST .GE. 10 ) THEN
        WRITE(6,*) ' INVERTED MATRIX '
        CALL WRTMAT(T,NORB,NORB,NORB,NORB)
      END IF
*.Subtract L
      DO 20 I = 1, NORB
      DO 20 J = 1,I-1
       T(I,J)= - WORK(KLL-1+I*(I-1)/2+J)
   20 CONTINUE
*
      IF( NTEST .NE. 0 ) THEN
        WRITE(6,*) ' INPUT X MATRIX '
        CALL WRTMAT(X,NORB,NORB,NORB,NORB)
        WRITE(6,*) ' T MATRIX '
        CALL WRTMAT(T,NORB,NORB,NORB,NORB)
      END IF
*
      RETURN
      END


PROGRAM kinds

  IMPLICIT NONE
  INTEGER, PARAMETER :: INT8 = SELECTED_INT_KIND(2)
  INTEGER, PARAMETER :: INT16 = SELECTED_INT_KIND(4)
  INTEGER, PARAMETER :: INT32 = SELECTED_INT_KIND(9)
  INTEGER, PARAMETER :: INT64 = SELECTED_INT_KIND(15)
  INTEGER, PARAMETER :: REAL32 = SELECTED_REAL_KIND(6, 37)
  INTEGER, PARAMETER :: REAL64 = SELECTED_REAL_KIND(15, 307)
  INTEGER, PARAMETER :: REAL128 = SELECTED_REAL_KIND(33, 4931)

  INTEGER(INT8) :: i1
  INTEGER(INT16) :: i2
  INTEGER(INT32) :: i3
  INTEGER(INT64) :: i4
  REAL(REAL32) :: r1
  REAL(REAL64) :: r2
  REAL(REAL128) :: r3

  !Print the largest number that can be held in each variable
  PRINT *, HUGE(i1)
  PRINT *, HUGE(i2)
  PRINT *, HUGE(i3)
  PRINT *, HUGE(i4)
  PRINT *, HUGE(r1)
  PRINT *, HUGE(r2)
  PRINT *, HUGE(r3)

END PROGRAM kinds


module quad_mod
    implicit none

    private
    public :: func_t

    interface
        function func_t(x) result(res)
            implicit none
            real, value :: x
            real :: res
        end function func_t
    end interface

    type, public, abstract :: quad_t
    contains
        procedure(compute_t), pass, deferred :: compute
    end type

    abstract interface
        function compute_t(this, func, a, b) result(val)
            import :: quad_t, func_t
            implicit none
            class(quad_t), intent(in) :: this
            procedure(func_t) :: func
            real, value :: a, b
            real :: val
        end function compute_t
    end interface

end module quad_mod


program mkltest

    implicit none

    integer :: i, n, incx, incy
    double precision ::  a
    double precision, dimension(1:3) :: x
    double precision, dimension(1:3) :: y
    double precision, dimension(1:3) :: res

    x(1) = 2.0
    x(2) = 1.0
    x(3) = -1.0

    y(1) = 1.0
    y(2) = 2.0
    y(3) = 3.0

    a = 2.0
    incx = 1
    incy = 1
    n = 3

    do i=1,3
        res(i) = a*x(i)+y(i)
        print *, 'res(',i,')=', res(i)
    end do

    print *, 'calling daxpy...'

    call daxpy(n, a, x, incx, y, incy)

    do i=1,3
        print *, 'y(',i,')=', y(i)
    end do

end program


SUBROUTINE PreProcessDiffStencils(FineGrid,DiffStencils,GhostGridX,GhostGridY,GhostGridZ,alpha,beta,gamma,fileop)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Diff_def), INTENT(OUT) :: DiffStencils
TYPE (Level_def), INTENT(IN) :: FineGrid
INTEGER :: GhostGridX,GhostGridY,GhostGridZ,STAT, fileop
INTEGER :: rank, Nx, Ny, Nz, order, Nzp, Diff, alpha, beta, gamma, i
REAL(KIND=long), DIMENSION(:), ALLOCATABLE :: Stencil
INTEGER, DIMENSION(:), ALLOCATABLE :: idx

! TEMPORARY POINTERS/VARIABLES
Nx = FineGrid%Nx
Ny = FineGrid%Ny
Nz = FineGrid%Nz
!print*,'Nx=',Nx
!print*,'Ny=',Ny
!print*,'Nz=',Nz
! Derivatives in x- and y-directions
!    Neumann conditions imposed by symmetric reflections
!    near walls. Central stencils everywhere.
rank = 2*alpha+1
!print*,'allocation'
ALLOCATE( DiffStencils%StencilX(Nx+2*GhostGridX,rank,2),STAT=STAT)
IF (STAT/=0) THEN
	PRINT*,'Error: Could not allocate memory for differentiation stencil (X).'
	STOP
ENDIF
DiffStencils%StencilX=zero
rank = 2*beta+1
!print*,'allocation'
ALLOCATE( DiffStencils%StencilY(Ny+2*GhostGridY,rank,2),STAT=STAT)
!print*,'hej'
IF (STAT/=0) THEN
	PRINT*,'Error: Could not allocate memory for differentiation stencil (Y).'
	STOP
ENDIF
DiffStencils%StencilY=zero

print*,'Building stencils...'
write(fileop,*)'Building stencils...'
DO order = 1,2
    IF (Nx>1) THEN
!    print*,'FineGrid%x=',FineGrid%x
		CALL BuildStencilsGridX(alpha,order,FineGrid%x,DiffStencils%StencilX(:,:,order),Nx+2*GhostGridX,Ny+2*GhostGridY)
!    print*,'DiffStencils%StencilX(:,:,order) = ',DiffStencils%StencilX(:,:,order)
!    read*
	ENDIF
	IF (Ny>1) THEN
		CALL BuildStencilsGridY(beta,order,FineGrid%y,DiffStencils%StencilY(:,:,order),Nx+2*GhostGridX,Ny+2*GhostGridY)
	ENDIF
END DO
!print*,'DONE!'

! Derivatives in z-direction
!    One-sided stencils near free surface.
!    One-side stencils near bottom, and if ghost points
!    are supported then the directional ghost point
!    is included in stencil.
IF (GhostGridZ==0) THEN; Nzp = Nz; ELSE; Nzp = Nz+1; ENDIF
ALLOCATE( DiffStencils%StencilZ(Nzp,2*gamma+1,2),STAT=STAT)
IF (STAT/=0) THEN
	PRINT*,'Error: Could not allocate memory for differentiation stencil (Z).'
	STOP
ENDIF
ALLOCATE( Stencil(2*gamma+1) )
ALLOCATE( idx(2*gamma+1) )
DO i=-gamma,gamma,1
	idx(i+gamma+1) = i
END DO
DO order=1,2
  DO i = 1, Nzp
	IF (i-1<gamma) THEN
		Diff = gamma-i+1
		CALL TaylorFDStencils1DArbitrary(gamma-Diff,gamma+Diff,order,Stencil,FineGrid%z(i+idx+Diff))
	ELSEIF (i>=Nz-gamma+1) THEN
		Diff = i-(Nzp-gamma)
		CALL TaylorFDStencils1DArbitrary(gamma+Diff,gamma-Diff,order,Stencil,FineGrid%z(i+idx-Diff))
	ELSE
		CALL TaylorFDStencils1DArbitrary(gamma,gamma,order,Stencil,FineGrid%z(i+idx))
	ENDIF
	DiffStencils%StencilZ(i,:,order) = Stencil
  END DO
END DO
DEALLOCATE(Stencil,idx)
END SUBROUTINE PreProcessDiffStencils


! SPDX-Identifier: MIT

module test_stdlib_math
    use testdrive, only : new_unittest, unittest_type, error_type, check
    use stdlib_math, only: clip
    use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, qp
    implicit none

    public :: collect_stdlib_math

contains

    !> Collect all exported unit tests
    subroutine collect_stdlib_math(testsuite)
        !> Collection of tests
        type(unittest_type), allocatable, intent(out) :: testsuite(:)

        testsuite = [ &
            new_unittest("clip-int8", test_clip_int8), &
            new_unittest("clip-int8-bounds", test_clip_int8_bounds), &
            new_unittest("clip-int16", test_clip_int16), &
            new_unittest("clip-int16-bounds", test_clip_int16_bounds), &
            new_unittest("clip-int32", test_clip_int32), &
            new_unittest("clip-int32-bounds", test_clip_int32_bounds), &
            new_unittest("clip-int64", test_clip_int64), &
            new_unittest("clip-int64-bounds", test_clip_int64_bounds), &
            new_unittest("clip-real-single", test_clip_rsp), &
            new_unittest("clip-real-single-bounds", test_clip_rsp_bounds), &
            new_unittest("clip-real-double", test_clip_rdp), &
            new_unittest("clip-real-double-bounds", test_clip_rdp_bounds), &
            new_unittest("clip-real-quad", test_clip_rqp), &
            new_unittest("clip-real-quad-bounds", test_clip_rqp_bounds) &
            ]

    end subroutine collect_stdlib_math

    subroutine test_clip_int8(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! clip function
        ! testing format: check(clip(x, xmin, xmax) == correct answer)
        ! valid case: xmin is not greater than xmax
        ! invalid case: xmin is greater than xmax

        ! type: integer(int8), kind: int8
        ! valid test case
        call check(error, clip(2_int8, -2_int8, 5_int8), 2_int8)
        if (allocated(error)) return
        call check(error, clip(127_int8, -127_int8, 0_int8), 0_int8)
        if (allocated(error)) return
    end subroutine test_clip_int8

    subroutine test_clip_int8_bounds(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! invalid test case
        call check(error, clip(2_int8, 5_int8, -2_int8), 5_int8)
        if (allocated(error)) return
        call check(error, clip(127_int8, 0_int8, -127_int8), 0_int8)
        if (allocated(error)) return
    end subroutine test_clip_int8_bounds

    subroutine test_clip_int16(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! type: integer(int16), kind: int16
        ! valid test case
        call check(error, clip(2_int16, -2_int16, 5_int16), 2_int16)
        if (allocated(error)) return
        call check(error, clip(32767_int16, -32767_int16, 0_int16), 0_int16)
        if (allocated(error)) return
    end subroutine test_clip_int16

    subroutine test_clip_int16_bounds(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! invalid test case
        call check(error, clip(2_int16, 5_int16, -2_int16), 5_int16)
        if (allocated(error)) return
        call check(error, clip(32767_int16, 0_int16, -32767_int16), 0_int16)
        if (allocated(error)) return
    end subroutine test_clip_int16_bounds

    subroutine test_clip_int32(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! type: integer(int32), kind: int32
        ! valid test case
        call check(error, clip(2_int32, -2_int32, 5_int32), 2_int32)
        if (allocated(error)) return
        call check(error, clip(-2147483647_int32, 0_int32, 2147483647_int32), 0_int32)
        if (allocated(error)) return
    end subroutine test_clip_int32

    subroutine test_clip_int32_bounds(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! invalid test case
        call check(error, clip(2_int32, 5_int32, -2_int32), 5_int32)
        if (allocated(error)) return
        call check(error, clip(-2147483647_int32, 2147483647_int32, 0_int32), 2147483647_int32)
        if (allocated(error)) return
    end subroutine test_clip_int32_bounds

    subroutine test_clip_int64(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! type: integer(int64), kind: int64
        ! valid test case
        call check(error, clip(2_int64, -2_int64, 5_int64), 2_int64)
        if (allocated(error)) return
        call check(error, clip(-922337203_int64, -10_int64, 25_int64), -10_int64)
        if (allocated(error)) return
    end subroutine test_clip_int64

    subroutine test_clip_int64_bounds(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! invalid test case
        call check(error, clip(2_int64, 5_int64, -2_int64), 5_int64)
        if (allocated(error)) return
        call check(error, clip(-922337203_int64, 25_int64, -10_int64), 25_int64)
        if (allocated(error)) return
    end subroutine test_clip_int64_bounds

    subroutine test_clip_rsp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! type: real(sp), kind: sp
        ! valid test case
        call check(error, clip(3.025_sp, -5.77_sp, 3.025_sp), 3.025_sp)
        if (allocated(error)) return
        call check(error, clip(0.0_sp, -1578.025_sp, -59.68_sp), -59.68_sp)
        if (allocated(error)) return
    end subroutine test_clip_rsp

    subroutine test_clip_rsp_bounds(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! invalid test case
        call check(error, clip(3.025_sp, 3.025_sp, -5.77_sp), 3.025_sp)
        if (allocated(error)) return
        call check(error, clip(0.0_sp, -59.68_sp, -1578.025_sp), -59.68_sp)
        if (allocated(error)) return
    end subroutine test_clip_rsp_bounds

    subroutine test_clip_rdp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! type: real(dp), kind: dp
        ! valid test case
        call check(error, clip(3.025_dp, -5.77_dp, 3.025_dp), 3.025_dp)
        if (allocated(error)) return
        call check(error, clip(-7.0_dp, 0.059668_dp, 1.00268_dp), 0.059668_dp)
        if (allocated(error)) return
    end subroutine test_clip_rdp

    subroutine test_clip_rdp_bounds(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! invalid test case
        call check(error, clip(3.025_dp, 3.025_dp, -5.77_dp), 3.025_dp)
        if (allocated(error)) return
        call check(error, clip(-7.0_dp, 1.00268_dp, 0.059668_dp), 1.00268_dp)
        if (allocated(error)) return
    end subroutine test_clip_rdp_bounds

    subroutine test_clip_rqp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! type: real(qp), kind: qp
        ! valid test case
        call check(error, clip(3.025_qp, -5.77_qp, 3.025_qp), 3.025_qp)
        if (allocated(error)) return
        call check(error, clip(-55891546.2_qp, -8958133457.23_qp, -689712245.23_qp), -689712245.23_qp)
        if (allocated(error)) return
    end subroutine test_clip_rqp

    subroutine test_clip_rqp_bounds(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        ! invalid test case
        call check(error, clip(3.025_qp, 3.025_qp, -5.77_qp), 3.025_qp)
        if (allocated(error)) return
        call check(error, clip(-55891546.2_qp, -689712245.23_qp, -8958133457.23_qp), -689712245.23_qp)
        if (allocated(error)) return

    end subroutine test_clip_rqp_bounds

end module test_stdlib_math

program tester
    use, intrinsic :: iso_fortran_env, only : error_unit
    use testdrive, only : run_testsuite, new_testsuite, testsuite_type
    use test_stdlib_math, only : collect_stdlib_math
    implicit none
    integer :: stat, is
    type(testsuite_type), allocatable :: testsuites(:)
    character(len=*), parameter :: fmt = '("#", *(1x, a))'

    stat = 0

    testsuites = [ &
        new_testsuite("stdlib-math", collect_stdlib_math) &
        ]

    do is = 1, size(testsuites)
        write(error_unit, fmt) "Testing:", testsuites(is)%name
        call run_testsuite(testsuites(is)%collect, error_unit, stat)
    end do

    if (stat > 0) then
        write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
        error stop
    end if
end program tester


      integer function len_blk_est(occ,nj,orb_info)

      implicit none

      include 'opdim.h'
      include 'def_orbinf.h'

      integer, intent(in) ::
     &   nj
      integer, intent(in) ::
     &   occ(ngastp,2,nj)
      type(orbinf) ::
     &   orb_info

      integer ::
     &   nhole, nvale, npart, nextr
      integer, external ::
     &   len_est__

      nhole = orb_info%nactt_hpv(IHOLE)
      nvale = orb_info%nactt_hpv(IVALE)
      npart = orb_info%nactt_hpv(IPART)
      nextr = orb_info%nactt_hpv(IEXTR)

      len_blk_est = len_est__(nhole,sum(occ(IHOLE,1:2,1:nj)))
     &             *len_est__(nvale,sum(occ(IVALE,1:2,1:nj)))
     &             *len_est__(npart,sum(occ(IPART,1:2,1:nj)))
     &             *len_est__(nextr,sum(occ(IEXTR,1:2,1:nj)))

      end

      integer function len_est__(norb,nidx)

      integer, intent(in) ::
     &    norb,nidx
      integer ::
     &    ii

      len_est__ = 1
      do ii = norb, max(1,norb-nidx+1), -1
        len_est__ = len_est__*ii
      end do

      end


	SUBROUTINE SNDINT ( nparms, levout, rdata,
     +			    nlevel, hghts, hdata, iret )
C************************************************************************
C* SNDINT								*
C*									*
C* This routine will interpolate data on pressure surfaces to data	*
C* on height surfaces.							*
C*									*
C* SNDINT ( NPARMS, LEVOUT, RDATA, NLEVEL, HGHTS, HDATA, IRET )		*
C*									*
C* Input parameters:							*
C*	NPARMS		INTEGER		Number of parameters		*
C*	LEVOUT		INTERGER	Number of output levels		*
C*	RDATA (LLMXLV)	REAL		Original sounding data		*
C*	NLEVEL		INTEGER		# of original sounding levels	*
C*	HGHTS (LEVOUT)	REAL		New height levels		*
C*									*
C* Output parameters:							*
C*	HDATA (LLMXLV)	REAL		Interpolated sounding data	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal			*
C**									*
C* Log:									*
C* S. Jacobs/SSAI	 4/92						*
C* J. Whistler/SSAI	 4/93		Cleaned up header		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'sndiag.prm'
C*
	REAL		rdata(*), hghts(*), hdata(*)
C*
	REAL		adata(2), bdata(2), outdat(2)
	LOGICAL		intflg(2), angflg(2)
C------------------------------------------------------------------------
	intflg(1) = .false.
	intflg(2) = .true.
	angflg(1) = .false.
	angflg(2) = .false.
C
	DO  i = 1, nparms
	    hdata(0*nparms+i) = rdata(0*nparms+i)
	END DO
C
	DO  n = 2, nparms
	    DO  l = 2, nlevel
		h1 = hghts(l)
		outdat(2) = RMISSD
		iret = -24
		k = 1
		DO WHILE ( iret .ne. 0 .and. k .lt. levout )
		    adata(1) = rdata((k-1)*nparms+IHGHT)
		    bdata(1) = rdata( k   *nparms+IHGHT)
		    adata(2) = rdata((k-1)*nparms+n)
		    bdata(2) = rdata( k   *nparms+n)
		    CALL PC_INTH  ( h1, adata, bdata, 2, intflg,
     +				    angflg, 1, outdat, iret )
		    k = k + 1
		    hdata((l-1)*nparms+IHGHT) = h1
		    hdata((l-1)*nparms+n) = outdat(2)
		END DO
	    END DO
	END DO
	iret = 0
C*
	RETURN
	END


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief calculate coefficents for the transport equation
!>    @param[in] spec species index
!>    @param[in] ismpl local sample index
!>    @details
!> calculate coefficents for the transport equation\n
!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
      SUBROUTINE set_ccoef(spec,ismpl)
        use arrays
        use mod_genrl
        use mod_genrlc
        use mod_flow
        use mod_conc
        use mod_time
        use mod_linfos
        IMPLICIT NONE
        integer :: i, j, k
        integer :: ismpl
        DOUBLE PRECISION di, dj, dk, por, vx, vy, vz, alfa
        EXTERNAL di, dj, dk, por, vx, vy, vz, alfa
        DOUBLE PRECISION v2, de, alf, p2
        INTEGER spec
!debug      write(99,'(a,3i4)') 'ShemSUITE i0,j0,k0:',i0,j0,k0

!$OMP master
        IF (linfos(3)>=2) WRITE(*,*) ' ... ccoef'
!$OMP end master

! inner points of grid - - - - - - - - - - - - - - - - - - - - - - - - -

!$OMP do schedule(static) collapse(3)
        DO k = 1, k0
          DO j = 1, j0
            DO i = 1, i0

              IF (i0>1) THEN
                IF (i<i0) THEN
                  de = di(i,j,k,spec,ismpl)
                  v2 = 0.5D0*vx(i,j,k,ismpl)
                  IF (de>0.D0) THEN
                    p2 = v2/de
                    alf = alfa(p2)
                  ELSE
                    alf = 0.D0
                    IF (v2<0.D0) alf = -1.D0
                    IF (v2>0.D0) alf = 1.D0
                  END IF
                  e(i,j,k,ismpl) = (de-(1.D0-alf)*v2)/delx(i)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (de+(1.D0+alf)*v2)/delx(i)
                END IF

                IF (i>1) THEN
                  de = di(i-1,j,k,spec,ismpl)
                  v2 = 0.5*vx(i-1,j,k,ismpl)
                  alf = 0.D0
                  IF (v2==0.D0) THEN
                    alf = 0.D0
                  ELSE
                    IF (de>0.D0) THEN
                      p2 = v2/de
                      alf = alfa(p2)
                    ELSE
                      IF (v2<0.D0) alf = -1.D0
                      IF (v2>0.D0) alf = 1.D0
                    END IF
                  END IF

                  c(i,j,k,ismpl) = (de+(1.D0+alf)*v2)/delx(i)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (de-(1.D0-alf)*v2)/delx(i)
                END IF
              END IF

              IF (j0>1) THEN

                IF (j<j0) THEN

                  de = dj(i,j,k,spec,ismpl)
                  v2 = 0.5*vy(i,j,k,ismpl)
                  alf = 0.D0
                  IF (v2==0.D0) THEN
                    alf = 0.D0
                  ELSE
                    IF (de>0.D0) THEN
                      p2 = v2/de
                      alf = alfa(p2)
                    ELSE
                      IF (v2<0.D0) alf = -1.D0
                      IF (v2>0.D0) alf = 1.D0
                    END IF
                  END IF

                  f(i,j,k,ismpl) = (de-(1.D0-alf)*v2)/dely(j)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (de+(1.D0+alf)*v2)/dely(j)
                END IF

                IF (j>1) THEN

                  de = dj(i,j-1,k,spec,ismpl)
                  v2 = 0.5*vy(i,j-1,k,ismpl)
                  alf = 0.D0
                  IF (v2==0.D0) THEN
                    alf = 0.D0
                  ELSE
                    IF (de>0.D0) THEN
                      p2 = v2/de
                      alf = alfa(p2)
                    ELSE
                      IF (v2<0.D0) alf = -1.D0
                      IF (v2>0.D0) alf = 1.D0
                    END IF
                  END IF

                  b(i,j,k,ismpl) = (de+(1.D0+alf)*v2)/dely(j)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (de-(1.D0-alf)*v2)/dely(j)
                END IF
              END IF

              IF (k0>1) THEN

                IF (k<k0) THEN

                  de = dk(i,j,k,spec,ismpl)
                  v2 = 0.5D0*vz(i,j,k,ismpl)
                  alf = 0.D0
                  IF (v2==0.D0) THEN
                    alf = 0.D0
                  ELSE
                    IF (de>0.D0) THEN
                      p2 = v2/de
                      alf = alfa(p2)
                    ELSE
                      IF (v2<0.D0) alf = -1.D0
                      IF (v2>0.D0) alf = 1.D0
                    END IF
                  END IF

                  g(i,j,k,ismpl) = (de-(1.D0-alf)*v2)/delz(k)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (de+(1.D0+alf)*v2)/delz(k)
                END IF

                IF (k>1) THEN

                  de = dk(i,j,k-1,spec,ismpl)
                  v2 = 0.5D0*vz(i,j,k-1,ismpl)
                  alf = 0.D0
                  IF (v2==0.D0) THEN
                    alf = 0.D0
                  ELSE
                    IF (de>0.D0) THEN
                      p2 = v2/de
                      alf = alfa(p2)
                    ELSE
                      IF (v2<0.D0) alf = -1.D0
                      IF (v2>0.D0) alf = 1.D0
                    END IF
                  END IF

                  a(i,j,k,ismpl) = (de+(1.D0+alf)*v2)/delz(k)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (de-(1.D0-alf)*v2)/delz(k)

                END IF

              END IF

            END DO
          END DO
        END DO
!$OMP end do nowait

        RETURN
      END

!>    @brief coefficents for the transport equation (here only the right side)
!>    @param[in] spec species index
!>    @param[in] ismpl local sample index
!>    @details
!> calculate coefficents for the transport equation\n
!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
      SUBROUTINE set_ccoefrs(spec,ismpl)
        use arrays
        use mod_genrl
        use mod_genrlc
        use mod_conc
        use mod_time
        use mod_linfos
        IMPLICIT NONE
        integer :: ismpl
        integer :: i, j, k

        ! DOUBLE PRECISION rhoceff
        DOUBLE PRECISION deltt
        ! INTEGER c1, c2, c3, c4
        INTEGER spec
        DOUBLE PRECISION deltat, por
        EXTERNAL deltat, por

        deltt = deltat(simtime(ismpl),ismpl)

! - - rhs: sources, also terms for transient calculations - - - - - - - - -

        IF (transient .AND. tr_switch(ismpl)) THEN

! - - - - - - - transient - - - - - - - - - - - - - - - - - - - - - - - - -
          CALL omp_mvp(i0,j0,k0,concold(1,spec,cgen_time,ismpl), &
            x(1,1,1,ismpl),a(1,1,1,ismpl),b(1,1,1,ismpl), &
            c(1,1,1,ismpl),d(1,1,1,ismpl),e(1,1,1,ismpl), &
            f(1,1,1,ismpl),g(1,1,1,ismpl))

!$OMP    do schedule(static) collapse(3)
          DO k = 1, k0
            DO j = 1, j0
              DO i = 1, i0

                d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                  por(i,j,k,ismpl)/(deltt*thetac)
                w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
                  por(i,j,k,ismpl)*concold(i+(j-1)*i0+(k-1)*i0*j0, &
                  spec,cgen_time,ismpl)/deltt - &
                  (1.D0-thetac)*x(i,j,k,ismpl)
                w(i,j,k,ismpl) = w(i,j,k,ismpl)/thetac
              END DO
            END DO
          END DO
!$OMP    end do nowait

        ELSE

! - - - - - - - - steady state - - - - - - - - - - - - - - - - - - - - -
! C$OMP    do schedule(static) collapse(3)
!          do k=1,k0
!             do j=1,j0
!                do i=1,i0
!                   w(i,j,k,ismpl) = w(i,j,k,ismpl)
!                     - hs(i,j,k,spec,ismpl)
!                end do
!             end do
!          end do
! C$OMP    end do nowait
        END IF

        RETURN
      END


    !use crop2mlModules
        IF ((phase .GE. 1.0) .AND. (phase .LT. 4.0)) THEN
            IF (hasFlagLeafLiguleAppeared .EQ. 0) THEN
                IF (phyllochron .EQ. 0.0) THEN
                    phyllochron = 0.0000001
                END IF
                leafNumber = leafNumber + MIN(deltaTT / phyllochron, 0.999)
            END IF
        END IF


!--------------------------------------------------------------------------------------
!
!Copyright (C) 2014 TopCoder Inc., All Rights Reserved.
!
!--------------------------------------------------------------------------------------

!   This module computes the means drift forces using the far-field momentum formulation for a infinite depth
!   case according to equation 4.1 and 4.2 of R1
!
!  R1 Computation of Higher-Order Hydrodynamic Forces on Ships and Offshore Structures in Waves
!             http://dspace.mit.edu/bitstream/handle/1721.1/79979/42664020.pdf?sequence=1
!
! Contest Drift forces and QTF Implementation of Nemoh
!
! Changes in version 1.1 (Implementation of Higher Order Panel Methods)
!       Added COMMON_TYPE module as dependency
!
! Changes in version 1.2 (Dipoles Implementation in NEMOH)
!       Switch from ParamsCommon to ParamsCommonInf
!
!   @author yedtoss
!   @version 1.2

module COMPUTE_MEAN_DRIFT_FORCES_INF

    USE COMMON_TYPE
    USE COM_VAR
    USE UTILITY
    USE KOCHIN

    implicit none

contains

    function driftintegral_fx(theta, param)
        ! computes abs(H(theta))**2*cos(theta)
        USE KOCHIN
        REAL, INTENT(IN) :: theta
        REAL :: driftintegral_fx
        TYPE(ParamsCommonInf) :: param
        COMPLEX :: HKochin

        CALL COMPUTE_KOCHIN(param%kwave, theta, HKochin, param%SolverVar)

        driftintegral_fx = (ABS(HKochin)**2)*COS(theta)

    end function driftintegral_fx

    function driftintegral_fy(theta, param)
        ! computes abs(H(theta))**2*sin(theta)

        USE KOCHIN
        REAL, INTENT(IN) :: theta
        REAL :: driftintegral_fy
        TYPE(ParamsCommonInf) :: param
        COMPLEX :: HKochin

        CALL COMPUTE_KOCHIN(param%kwave, theta, HKochin, param%SolverVar)

        driftintegral_fy = (ABS(HKochin)**2)*SIN(theta)

    end function driftintegral_fy

    subroutine compute_mean_drift_forces_infinite(param, drift_forces)
        ! This is the main subrouting computing the drift_forces
        ! It use romberg_trap to integrate the function driftintegral_fy and driftintegral_fx

        REAL :: PI
        TYPE(ParamsCommonInf) :: param
        REAL, DIMENSION(2) :: drift_forces !
        COMPLEX :: HKochin

        PI=4.*ATAN(1.)

        drift_forces(1) = (RHO* (param%kwave**2)/(8*PI))*romberg_trap(driftintegral_fx, 0., 2*PI, 1e-3, 20, param)
        drift_forces(2) = (RHO* (param%kwave**2)/(8*PI))*romberg_trap(driftintegral_fy, 0., 2*PI, 1e-3, 20, param)

        CALL COMPUTE_KOCHIN(param%kwave, PI+param%beta, HKochin, param%SolverVar)

        drift_forces(1) = drift_forces(1) + 0.5*RHO*param%w*param%AKH*cos(param%beta)*REAL(HKochin)
        drift_forces(2) = drift_forces(2) + 0.5*RHO*param%w*param%AKH*sin(param%beta)*REAL(HKochin)

    end subroutine compute_mean_drift_forces_infinite

end module COMPUTE_MEAN_DRIFT_FORCES_INF


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine distattachline(xig,etg,pneigh,pnode,a,p,
     & ratio,nterms,xn)
!
!     calculates the distance between a straight line through the node
!     with coordinates in "pnode" and direction vector "xn" and
!     the node with local coordinates xig and etg
!     in a face described by "nterms" nodes with coordinates
!     in "pneigh"
!
      implicit none
!
      integer nterms,i,j
!
      real*8 ratio(8),pneigh(3,*),pnode(3),a,xi,et,xig,etg,p(3),
     &  dummy,xn(3),coeff
!
      if(nterms.eq.3) then
         xi=(xig+1.d0)/2.d0
         et=(etg+1.d0)/2.d0
         if(xi+et.gt.1.d0) then
            dummy=xi
            xi=1.d0-et
            et=1.d0-dummy
         endif
         ratio(1)=1.d0-xi-et
         ratio(2)=xi
         ratio(3)=et
      elseif(nterms.eq.4) then
         xi=xig
         et=etg
         ratio(1)=(1.d0-xi)*(1.d0-et)/4.d0
         ratio(2)=(1.d0+xi)*(1.d0-et)/4.d0
         ratio(3)=(1.d0+xi)*(1.d0+et)/4.d0
         ratio(4)=(1.d0-xi)*(1.d0+et)/4.d0
      elseif(nterms.eq.6) then
         xi=(xig+1.d0)/2.d0
         et=(etg+1.d0)/2.d0
         if(xi+et.gt.1.d0) then
            dummy=xi
            xi=1.d0-et
            et=1.d0-dummy
         endif
         ratio(1)=2.d0*(0.5d0-xi-et)*(1.d0-xi-et)
         ratio(2)=xi*(2.d0*xi-1.d0)
         ratio(3)=et*(2.d0*et-1.d0)
         ratio(4)=4.d0*xi*(1.d0-xi-et)
         ratio(5)=4.d0*xi*et
         ratio(6)=4.d0*et*(1.d0-xi-et)
      elseif(nterms.eq.8) then
         xi=xig
         et=etg
         ratio(1)=(1.d0-xi)*(1.d0-et)*(-xi-et-1.d0)/4.d0
         ratio(2)=(1.d0+xi)*(1.d0-et)*(xi-et-1.d0)/4.d0
         ratio(3)=(1.d0+xi)*(1.d0+et)*(xi+et-1.d0)/4.d0
         ratio(4)=(1.d0-xi)*(1.d0+et)*(-xi+et-1.d0)/4.d0
         ratio(5)=(1.d0-xi*xi)*(1.d0-et)/2.d0
         ratio(6)=(1.d0+xi)*(1.d0-et*et)/2.d0
         ratio(7)=(1.d0-xi*xi)*(1.d0+et)/2.d0
         ratio(8)=(1.d0-xi)*(1.d0-et*et)/2.d0
      else
         write(*,*) '*ERROR in distattach: case with ',nterms
         write(*,*) '       terms is not covered'
         call exit(201)
      endif
!
!     calculating the position in the face
!
      do i=1,3
         p(i)=0.d0
         do j=1,nterms
            p(i)=p(i)+ratio(j)*pneigh(i,j)
         enddo
      enddo
!
!     calculating the distance
!
c      a=(pnode(1)-p(1))**2+(pnode(2)-p(2))**2+(pnode(3)-p(3))**2
      coeff=0.0
      do i=1,3
         coeff=coeff+xn(i)*(p(i)-pnode(i))
      enddo
      a=(p(1)-pnode(1)-coeff*xn(1))**2+(p(2)-pnode(2)-
     &     coeff*xn(2))**2+(p(3)-pnode(3)-coeff*xn(3))**2
!
      return
      end