!=======================================================================
!  DayCent_diffusivity, Subroutine
!
!     dD0_fc = f(dul, bd, wfps_fc)
!
!-----------------------------------------------------------------------
!  Revision history
!  06/12/2014 PG / CHP Written
!-----------------------------------------------------------------------
!  Called : SOIL
!  Calls  : Fert_Place, IPSOIL, NCHECK, NFLUX, RPLACE,
!           SOILNI, YR_DOY, FLOOD_CHEM, OXLAYER
!=======================================================================
      subroutine DayCent_diffusivity(dD0, sw, soilprop)
!      the variable dDO_fc is manually calculated for the moment

      use ModuleDefs
      real, dimension(NL), intent(out):: dD0
      real, dimension(NL), intent(IN) :: SW
      integer L, nlayr
      type (SoilType), intent(in) :: SOILPROP

      real, dimension(NL) :: dul, bd, poros
      real, dimension(NL) :: dD0_fc, dD0_DayCent, ratio
      real POROSer

      BD    = SOILPROP % BD
      DUL   = SOILPROP % DUL
      POROS = SOILPROP % POROS
      NLAYR = SOILPROP % NLAYR

! From Iurii Shcherbak 6 July 2014
! Linear model
! Dfc = 0.741804 - 0.287059 BD - 0.755057 FC
! Adj R^2 = 0.999412
!
! Quadratic
! Dfc = 0.906277 - 0.461712 BD + 0.045703 BD^2 - 1.19827 FC +  0.225558 BD FC + 0.292491 FC^2
! Adj R^2 = 0.999997

      do L = 1, Nlayr
!       Linear
!       dD0_fc(L) = 0.741804 - 0.287059 * BD(L) - 0.755057 * FC(L)

!       Quadratic
        dD0_fc(L) = 0.906277 - 0.461712 * BD(L)
     &                       + 0.045703 * BD(L) * BD(L)
     &                       - 1.19827  * DUL(L)
     &                       + 0.225558 * BD(L) * DUL(L)
     &                       + 0.292491 * DUL(L) * DUL(L)
      enddo

!     Temporary function for diffusivity - set to constant for now
!      dD0_fc = 0.10    ! 0.10 for KT, fixed value since diffusivity routine is not working
!      dD0_fc = 0.16    ! 0.16 for KY, fixed value since diffusivity routine is not working
!      dD0_fc = 0.11    ! 0.11 for Canada (use KT), fixed value since diffusivity routine is not working
!      dD0_fc = 0.21    ! 0.21 for India, fixed value since diffusivity routine is not working
!      dD0_fc = 0.09    ! 0.09 for France (use KT), fixed value since diffusivity routine is not working

!*****************************************************************************
!*****************************************************************************
!!     Diffusivity from DayCent:
!!     chp 4/18/2017
!
!*              Copyright 1993 Colorado State University                    *
!*                      All Rights Reserved                                 *
!
!*****************************************************************************
!**
!**  FILE:      diffusiv.c
!**
!**  FUNCTION:  float diffusiv()
!**
!**  PURPOSE:   For estimating normalized diffusivity in soils.  Method of
!**             Millington and Shearer (1971) Soil Science Literature Source:
!**             Davidson, E.A. and S.E. Trumbore (1995).
!**             Contributed by Chris Potter, NASA Ames
!**
!**  INPUTS:
!**    A       - is the fraction of soil bed volume occuppied by field capacity
!**              (intra-aggregate pore space), units 0-1
!**    bulkden - bulk density (g/cm3)
!**    wfps    - water-filled pore space (fraction 0.0-1.0)
!**              (fraction of a porespace that is filled with water)
!**              volumetric water / porosity
!**
!**  GLOBAL VARIABLES:
!**    None
!**
!**  LOCAL VARIABLES:
!**    debug      - flag to set debugging mode, 0 = off, 1 = on
!**    my_theta_V - testing alternate way of computing the volumetric water
!**                 content of the soil bed volume
!**    PARTDENS   - particle density (g/cm3)
!**    pfc        - water content of soil expressed as a percent of field
!**                 capacity (%)
!**    porosity   - the fraction of soil bed volume occupied by pore space (P)
!**                 (A + inter-aggregate pore space), units 0-1
!**                  = 1 - bulkden/particle density
!**    sw_p       - the fractional liquid saturation of the P component of
!**                 total pore volume
!**    s_wat      - the fractional liquid saturation of the A component of
!**                 total pore volume
!**    theta_A    - the volume of water per unit bed volume contained in
!**                 intra-aggregate pore space
!**    theta_P    - the volume of water per unit bed volume contained in
!**                 inter-aggregate pore space
!**    theta_V    - the volumetric water content of the soil bed volume
!**    tp1 .. tp8 - intermediate variables
!**    vfrac      - volumetric fraction
!**
!**  OUTPUT:
!**    dDO - the normalized diffusivity in aggregate soil media, units 0-1
!
      do L = 1, Nlayr
!       Inter-aggregate porosity
        POROSer = POROS(L) - DUL(L)
        pfc = SW(L) / DUL(L) * 100.   !water content as percent of DUL
        if (pfc >= 100.) then
          VFRAC = (SW(L) - DUL(L)) / POROSer
          THETA_V = DUL(L) + MIN(VFRAC,1.0) * (POROS(L) - DUL(L))
        else
          VFRAC = 0.0
          THETA_V = SW(L)
        endif

        THETA_P = MAX(0.0, (THETA_V - DUL(L)))
        THETA_A = MIN(DUL(L), THETA_V)

        S_WAT = MIN(1.0, SW(L)/DUL(L))
        SW_P = MIN(1.0, THETA_P/POROSer)

        TP1 = (1.0 - S_WAT) ** 2.0
        TP2 = (DUL(L) - THETA_A) / (1.0 - POROSer)
        TP3 = TP2 ** (0.5*TP2 + 1.16)
        TP4 = 1.0 - POROSer ** (0.5*POROSer + 1.16)
        TP5 = POROSer - THETA_P
        TP6 = MAX(0.0, TP5 ** (0.5*TP5 + 1.16))
        TP7 = (1.0 - SW_P) ** 2.0
        TP8 = MAX(0.0, (TP1 * TP3 * TP4 * (TP5-TP6)) /
     &   (1.E-6 + (TP1 * TP3 * TP4) + TP5 - TP6) * 1.E7)

        dD0_DayCent(L) = MAX(0.0, (TP8/1.E7 + TP7 * TP6))

!*****************************************************************************
!       compare with Shcherbak method
        ratio(L) = dD0_DayCent(L) / dD0_fc(L)
!        write(555,'(i5,4f10.4)') L,SW(L),dD0_fc(L), dD0_chp(L), ratio(L)
      enddo

      dD0 = dD0_DayCent

      return
      end subroutine DayCent_diffusivity
!=======================================================================


      Module mba3d_mba_analytic
C
      use mba3d_ani2
C
      contains
C
C ================================================================
      Subroutine mbaAnalytic(
C ================================================================
c group (M)
     &      nP, MaxP, nF, MaxF, nE, MaxE,
     &      XYP, IPF, IPE, lbF, lbE,
     &      nEStar,
c group (Dev)
     &      nPv, nFv, nEv, IPV, IFV, IEV,
     &      flagAuto, status,
c group (Q)
     &      MaxSkipE, MaxQItr,
     &      MetricFunction, Quality, rQuality,
c group (W)
     &      MaxWr, MaxWi, rW, iW,
     &      iPrint, iERR)
C ================================================================
      include 'status.fd'
      include 'magic.fd'
      include 'output.fd'
C ================================================================
C VARIABLES & PARAMETER are decribed in mba_nodal.f except
C
C  MetricFunction - integer function created by the user (see example
C                in file forlibmba.f)
C
C    Integer Function MetricFunction(x, y, z, Metric)
C
C  This routine creates a metric at the given point (x,y, z). The
C  metric is a 3x3 positive definite symmetric tensor:
C                M11   M12   M13
C      Metric =  M12   M22   M23
C                M13   M23   M33
C
C  Only the upper triangular part of array Metric must be defined.
C
C
C *** Authors: K. Lipnikov     (lipnikov@hotmail.com)
C              Yu. Vassilevski (vasilevs@dodo.inm.ras.ru)
C *** Date:   1997 - 2008
C *** Updates: see ChangeLog
C
C ==========================================================
C group (M)
C     Integer MaxP, MaxF, MaxE
      Real*8  XYP(3, *)
      Integer IPE(4, *), IPF(3, *)
      Integer IPV(*), lbF(*), lbE(*)

C group (Dev)
      Integer nFv, nEv, IFV(*), IEV(*)
      Logical flagAuto
      Integer status

C group (Q)
      Integer  MaxSkipE, MaxQItr
      Real*8   Quality, rQuality
      Logical  flagAnalytic

      Integer  MetricFunction
      EXTERNAL MetricFunction

C group (W)
      Real*8  rW(*)
      Integer iW(*)

C group (Local variables)
      Logical flagFILE
      Integer chanelOUT, statusWork
      Real*8  hStar, tm0, tm1
      Character*80 message
      Character*(LineLenght) output(MaxLines)

      iERR = 0

      iPrintl   = mod(iPrint, 10)
      chanelOUT = iPrint / 10
      flagFILE  = iPrint.GE.10

      If(chanelOUT.GE.100) Call errMes(4201, 'ani_metric',
     &                          'output chanel number is wrong')

      If(flagFILE) Then
         Open(chanelOUT, file='aniMPI.log', status='UNKNOWN')
      End if

      nLines = 0
      nLoop = 1

c ... print header
      If(iPrintl.GE.1) Then
         If(flagFILE) Then
            Write(chanelOUT, 5001) Quality, nEStar, MaxQItr
         Else
            Write(*, 5001) Quality, nEStar, MaxQItr
         End if
      End if

      Call setStatus(flagAuto, status, iPrint)
      statusWork = status

c ... starting clocks
      Call mba3d_seconds(tm0)

c ... memory for sequantial running (is cleaned)
c     iW(1) is overloaded to return colors & nQItr
      ilbP = 1
      iIPF = 1
      iIPE = iIPF + 4 * MaxF
      iIPP = iIPE + 5 * MaxE
      iICP = iIPP + MaxP
      iIHolP = iICP + MaxP
      iIHolF = iIHolP + MaxP
      iIHolE = iIHolF + MaxF
      iIEP = iIHolE + MaxE
      iIFE = iIEP + MaxP
      iIEE = iIFE + 4 * MaxE
      iL1E = iIEE + 4 * MaxE
      iL2E = iL1E + 2 * MaxE
      iIEPw = iL2E + MaxE
      inEPw = iIEPw + max(4 * MaxE, 3 * MaxF)
      iIPEw = inEPw + MaxP
      iiSE  = iIPEw + 4 * nE

      miLINTRP = MaxWi - iiSE
      If(miLINTRP.LE.MaxP + MaxF) Then
         iERR = 1001
         Write(message,'(A,I10)')
     &        'The approximate size of iW is ', iiSE + MaxP + MaxF
         Call errMes(iERR, 'mbaAnalytic', message)
      End if

c ... memory for sequantial running (is cleaned)
c     rW(1) is overloaded to return total time
      iHesP = 1
      idG = iHesP + 6 * MaxP
      iqE = idG + MaxP
      iHesPw = iqE + MaxE
      iXYPw = iHesPw + 6 * nP
      irSE = iXYPw + 3 * nP

      mrLINTRP = MaxWr - irSE
      If(mrLINTRP.LT.MaxE) Then
         iERR = 1002
         Write(message,'(A,I10)')
     &        'The approximate size of rW is ', irSE + nE
         Call errMes(iERR, 'mbaAnalytic', message)
      End if

      Do n = 1, MaxWr
         rW(n) = 0D0
      End do

      Do n = 1, MaxWi
         iW(n) = 0
      End do

c ... auxiliary structure of the data
      m = iIPF - 1
      Do n = 1, nF
         Do i = 1, 3
            iW(m + i) = IPF(i, n)
         End do
         iW(m + 4) = lbF(n)
         m = m + 4
      End do

      m = iIPE - 1
      Do n = 1, nE
         Do i = 1, 4
            iW(m + i) = IPE(i, n)
         End do
         iW(m + 5) = lbE(n)
         m = m + 5
      End do

c ... metric field is generated by user's formulae in the physical space
      Call iniQ_analytic(nP, XYP, MetricFunction, rW(iHesP))

c ... scale geometry to unit cube
      Call scale2Cube(nP, XYP, .TRUE.)

c ... quality of tetrahedra is computed
      Call makQ(
     &     nLoop,
c group (M)
     &     nP, nE, XYP, IPE, nEv, IEV,
     &     nEStar, hStar,
c group (Q)
     &     rW(iHesP), rW(idG), rW(iqE))

c ... setting the fixed metric for the future loops
      nPw = nP
      nEw = nE
      Call copyMeshData(nP, nE, XYP, rW(iHesP), IPE,
     &                  rW(iXYPw), rW(iHesPw), iW(iIPEw))

c... runing the basic algorithm for the global grid
      flagAnalytic = .TRUE.
      Call ani2(
c group (M)
     &     nP, MaxP, nF, MaxF, nE, MaxE,
     &     XYP, iW(iIPF), iW(iIPE),
     &     nEStar, hStar,
     &     iW(iICP), iW(iIPP), iW(iIEP),
     &     iW(iIFE), iW(iIEE),
     &     iW(iL1E), iW(iL2E),
     &     iW(iIHolP), iW(iIHolF), iW(iIHolE),
     &     iW(iIEPw), iW(inEPw),
     &     miLINTRP, mrLINTRP, iW(iIPEw), iW(iiSE),
     &     flagAuto, statusWork,
c group (Dev)
     &      nPv, nFv, nEv, IPV, IFV, IEV,
c group (Q)
     &     MaxSkipE, MaxQItr, MaxBasketsGrid,
     &     rW(iHesP), Quality, rQuality,
     &     rW(idG), rW(iqE),
     &     nPw, nEw, rW(iXYPw), rW(iHesPw), rW(irSE),
     &     MetricFunction, flagAnalytic,
c group (ERR)
     &     flagFILE, chanelOUT, nLines, output,
     &     iPrintl, nQItr, iERR)

      If(iERR.NE.0 .AND. iERR.NE.1000)
     &   Call errMes(iERR, 'mbaAnalytic', 'memory problems')

      Call mba3d_seconds(tm1)
      tm1 = tm1 - tm0

      If(iPrintl.GE.1) Then
         If(flagFILE) Then
            Do i = 1, nLines
               Write(chanelOUt,'(A)') output(i)
            End do

            Write(chanelOUT, 5003) nQItr, rQuality, nP, nF, nE, tm1
         Else
            Write(*, 5003) nQItr, rQuality, nP, nF, nE, tm1
         End if
      End if

      If(flagFILE) Close(chanelOUT)

c ... rescale geometry back
      Call scale2Cube(nP, XYP, .FALSE.)

c ... original structure of the data
      m = iIPF - 1
      Do n = 1, nF
         Do i = 1, 3
            IPF(i, n) = iW(m + i)
         End do
         lbF(n) = iW(m + 4)
         m = m + 4
      End do

      m = iIPE - 1
      Do n = 1, nE
         Do i = 1, 4
            IPE(i, n) = iW(m + i)
         End do
         lbE(n) = iW(m + 5)
         m = m + 5
      End do

      Do n = 1, nP
         iW(n) = iW(iICP + n - 1)
      End do
      iW(nP + 1) = nQItr

      rW(1) = tm1
      rW(2) = rQuality
      rW(3) = hStar

      Do n = 1, nE
         rW(3 + n) = rW(iqE + n - 1)
      End do

      Return

 5001 Format(/,
     &    'STONE FLOWER! (1997-2008), version 2.1', /,
     &    'Target: Quality', F5.2, ' with', I9,
     &    ' tetrahedra for at most', I9, ' iterations',/)

 5002 Format(/,'Processor :', I4)

 5003 Format('Total:', I6, ' Q=', E10.4, '  #V,F,E:', I7,I8,I9,
     &       '  tm=', F6.1, 's',/)
      End Subroutine mbaAnalytic

C ================================================================
      Subroutine mbaAnalyticShort(
C ================================================================
c group (M)
     &      nP, MaxP, nF, MaxF, nE, MaxE,
     &      XYP, IPF, IPE, lbF,
     &      nEStar, status,
c group (W)
     &      MaxWr, MaxWi, rW, iW,
     &      iPrint, iERR)
C ================================================================
C group (M)
      Real*8  XYP(3, *)
      Integer IPE(4, *), IPF(3, *)
      Integer lbF(*)
      Integer status

C group (W)
      Real*8  rW(*)
      Integer iW(*)

C group (Local variables)
      Real*8   Quality, rQuality
      Logical  flagAuto
      EXTERNAL MetricFunction_ani
      Character*80 message

C ================================================================
      iERR = 0

      MaxWiAv =  7 * MaxP + nP + 9 * MaxF + 19 * MaxE + 13 * nE
      MaxWrAv = 14 * MaxP + 14 * nP + MaxE

      If(MaxWi.LE.MaxWiAv) Then
         iERR = 1001
         Write(message,'(A,I10)')
     &        'The approximate size of iW is ', MaxWiAv
         Call errMes(iERR, 'mbaAnalyticShort', message)
      End if

      If(MaxWr.LE.MaxWrAv) Then
         iERR = 1002
         Write(message,'(A,I10)')
     &        'The approximate size of rW is ', MaxWrAv
         Call errMes(iERR, 'mbaAnalyticShort', message)
      End if

c ... setup of missing parameter
      nPv = 0
      nFv = 0
      nEv = 0
      flagAuto = .TRUE.

      MaxSkipE = 200
      MaxQItr  = min(50 000, nE)
      Quality  = 0.3D0

      iIPV = 1
      ilbE = iIPV + MaxF
      iIFV = ilbE + MaxE
      iIEV = iIFV + nFV
      iiEnd = iIEV + nEV + 1

      Do n = 0, nE - 1
         iW(ilbE + n) = 1
      End do

      Call mbaAnalytic(
c group (M)
     &      nP, MaxP, nF, MaxF, nE, MaxE,
     &      XYP, IPF, IPE, lbF, iW(ilbE),
     &      nEStar,
c group (Dev)
     &      nPv, nFv, nEv, iW(iIPV), iW(iIFV), iW(iIEV),
     &      flagAuto, status,
c group (Q)
     &      MaxSkipE, MaxQItr,
     &      MetricFunction_ani, Quality, rQuality,
c group (W)
     &      MaxWr, MaxWi - iiEnd, rW, iW(iiEnd),
     &      iPrint, iERR)

      Return
      End Subroutine mbaAnalyticShort
C
      End Module mba3d_mba_analytic


      PROGRAM CTEX01
C
C
C D E S C R I P T I O N ------------------------------------------------
C
C
C This example illustrates the use of CONPACKT to draw contours on a
C simple triangular mesh derived from a rectangular grid in the plane
C and it shows, in great detail, how the mesh was constructed.  If you
C want to learn how to do that, this is the best example to study; if
C not, you may find one of the other examples somewhat easier to follow,
C since, in general, those examples use one of the two canned routines
C in CONPACKT to construct a triangular mesh.
C
C
C D E C L A R A T I O N S ----------------------------------------------
C
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.  Use one
C of the following:
C
C       PARAMETER (IERF=6,LUNI=2,IWTY=1 ,IWID=1)  !  NCGM
C       PARAMETER (IERF=6,LUNI=2,IWTY=8 ,IWID=1)  !  X Windows
C       PARAMETER (IERF=6,LUNI=2,IWTY=20,IWID=1)  !  PostScript
C       PARAMETER (IERF=6,LUNI=2,IWTY=11,IWID=1)  !  PDF, Portrait
C       PARAMETER (IERF=6,LUNI=2,IWTY=12,IWID=1)  !  PDF, Landscape
C
        PARAMETER (IERF=6,LUNI=2,IWTYPE=1,IWTY=IWTYPE,IWID=1)
C
C Assume we have a regular rectangular grid, dimensioned IDIM x JDIM,
C where IDIM is the number of points in a horizontal row and JDIM is
C the number of rows.
C
        PARAMETER (IDIM=7,JDIM=7,IDM1=IDIM-1,JDM1=JDIM-1)
C
C Let the values of X corresponding to the left and right edges of the
C grid be XMIN and XMAX and the values of Y corresponding to the bottom
C and top edges of the grid be YMIN and YMAX.
C
        PARAMETER (XMIN=-1.,XMAX=+1.,YMIN=-1.,YMAX=+1.)
C
C An arithmetic statement function Z(X,Y), appearing below, defines
C the data field to be contoured on the mesh.
C
C We derive a triangular mesh from the rectangular grid by dividing
C each rectangular cell in half along one of its diagonals (from lower
C left to upper right in half of them and from upper left to lower right
C in the other half).  To represent the triangular mesh, we use three
C singly-dimensioned arrays: RPNT holds information about points; IEDG,
C information about edges; and ITRI, information about triangles.  The
C elements of each array form "nodes" having lengths as follows:
C
        PARAMETER (LOPN=4)
        PARAMETER (LOEN=5)
        PARAMETER (LOTN=4)
C
C The four elements of a point node, in RPNT, are
C
C   1. the X coordinate of the point;
C   2. the Y coordinate of the point;
C   3. the Z coordinate of the point (always 0 in this example);
C   4. the field value at the point;
C
C The five elements of an edge node, in IEDG, are
C
C   1. the "base index", in RPNT, of point 1 of the edge;
C   2. the "base index", in RPNT, of point 2 of the edge;
C   3. the index, in ITRI, of the pointer to the edge in the node for
C      the triangle to its left (-1 if there is no triangle there);
C   4. the index, in ITRI, of the pointer to the edge in the node for
C      the triangle to its right (-1 if there is no triangle there);
C   5. a utility flag for use by algorithms that scan the structure.
C
C (The "left" and "right" sides of an edge are defined as they would be
C by an observer standing at point 1 of the edge, looking toward point
C 2 of the edge.  It is possible, if there are "holes" in the mesh, that
C there will be no triangle to the left or to the right of an edge, but
C there must be a triangle on one side or the other.)
C
C The four elements of a triangle node, in ITRI, are
C
C   1. the "base index", in IEDG, of edge 1 of the triangle;
C   2. the "base index", in IEDG, of edge 2 of the triangle;
C   3. the "base index", in IEDG, of edge 3 of the triangle;
C   4. a flag set non-zero to block use of the triangle, effectively
C      removing it from the mesh.
C
C The edges pointed to by a triangle node must be in counterclockwise
C order, as viewed from above the mesh.
C
C The "base index" of a point node, an edge node, or a triangle node is
C a non-negative multiple of the length of the node, to which can be
C added an offset to get the index of a particular element of the node.
C Suppose I is the base index of a triangle node; then ITRI(I+1) is
C the triangle node's first element, whose value is the base index of
C the node in IEDG that describes the first edge of the triangle.  So
C IEDG(ITRI(I+1)+2) is the second element of that edge node (whose value
C is the base index of the node describing the second point of the first
C edge of the triangle with base index I.  Similarly, then, we see that
C RPNT(IEDG(ITRI(I+1)+2)+3) is the third (Z) coordinate of the second
C point of the first edge of the triangle with base index I.
C
C The pointers from edge nodes back to triangle nodes (elements 3 and 4)
C allow CONPACKT to navigate the mesh, moving from triangle to triangle
C as it follows a contour line; the pointers are a bit trickily defined:
C if IPTE is the base index of an edge node and IEDG(IPTE+3) is zero or
C more, saying that there is a triangle to the left of the edge, then
C IEDG(IPTE+3) is the actual index of that element of the triangle node
C that points to the edge node; i.e., ITRI(IEDG(IPTE+3))=IPTE.  The base
C index of the triangle node is IPTL, where IPTL is the largest multiple
C of LOTN which is less than IEDG(IPTE+3), as defined by the formula
C IPTL=LOTN*((IEDG(IPTE+3)-1)/LOTN), and the index of the pointer to
C the edge within the triangle node is IPIL=IEDG(IPTE+3)-IPTL (which
C will have the value 1, 2, or 3); observe that IEDG(IPTL+IPIL)=IPTE.
C Similar comments apply to element 4 of an edge node, which, if zero or
C more, points into the triangle node defining the triangle to the right
C of the edge: ITRI(IEDG(IPTE+4))=IPTE; the base index of the node for
C the triangle to the right is IPTR=LOTN*((IEDG(IPTE+4)-1)/LOTN); the
C index of the pointer to the edge within the triangle node is IPIR=
C IEDG(IPTE+4)-IPTR; and, again, observe that IEDG(IPTR+IPIR)=IPTE.
C
C Compute the number of point nodes, edge nodes, and triangle nodes that
C the triangular mesh arrays will need to hold.  The formulas for the
C numbers of point nodes and triangle nodes ought to be quite obvious.
C The one for the number of edge nodes may not be quite so obvious; it
C is based on the facts that each cell of the rectangular grid contains
C one horizontal edge, one vertical edge, and one diagonal edge; that
C there are IDM1 more horizontal edges along the top of the grid; and
C that there are JDM1 more vertical edges along the right edge of the
C grid.
C
        PARAMETER (NOPN=IDIM*JDIM)
        PARAMETER (NOEN=3*IDM1*JDM1+IDM1+JDM1)
        PARAMETER (NOTN=2*IDM1*JDM1)
C
C Now, compute the amount of space we will need in the arrays.
C
        PARAMETER (NPNT=NOPN*LOPN)
        PARAMETER (NEDG=NOEN*LOEN)
        PARAMETER (NTRI=NOTN*LOTN)
C
C Declare the arrays to hold the point nodes, edge nodes, and triangle
C nodes defining the triangular mesh.
C
        DIMENSION RPNT(NPNT),IEDG(NEDG),ITRI(NTRI)
C
C Declare real and integer workspaces needed by CONPACKT.
C
        PARAMETER (LRWK=10000,LIWK=1000)
C
        DIMENSION RWRK(LRWK),IWRK(LIWK)
C
C Declare a character temporary for use in labeling.
C
        CHARACTER*3 CTMP
C
C Declare the area map array needed to do solid fill.
C
        PARAMETER (LAMA=40000)
C
        DIMENSION IAMA(LAMA)
C
C Declare workspace arrays to be used in calls to the AREAS routine
C ARSCAM.
C
        PARAMETER (NCRA=4000,NGPS=2)
C
        DIMENSION XCRA(NCRA),YCRA(NCRA),IAAI(NGPS),IAGI(NGPS)
C
C Declare external the routine that does color fill of contour bands.
C
        EXTERNAL DCFOCB
C
C
C A R I T H M E T I C   S T A T E M E N T   F U N C T I O N S ----------
C
C
C This function Z(X,Y) defines the field of data to be contoured on the
C mesh; the first line defines it as 10 times the square of the distance
C from the origin (a paraboloid); the commented-out version defines a
C "monkey saddle".
C
        Z(X,Y)=10.*(X*X+Y*Y)
C       Z(X,Y)=10.*(X*X-Y*Y)
C
C The rest of the arithmetic statement functions are used to enumerate
C the points, edges, and triangles of the rectangular mesh, so that we
C can assign each of them to a unique position in the arrays defining
C the point nodes, the edge nodes, and the triangle nodes of the
C triangular mesh.  (The first frame produced by this program shows the
C enumerations of the points, edges, and triangles, as determined by
C the functions, and will be helpful while reading their descriptions.)
C
C The value of the function INPT(I,J) is a unique integer between 1 and
C IDIM*JDIM, to be assigned to the point of the rectangular mesh having
C indices (I,J).  INPT enumerates the IDIM*JDIM points of the mesh, row
C by row, from bottom to top, and, within each row, from left to right.
C
        INPT(I,J)=(J-1)*IDIM+I
C
C The value of the function INE1(I,J) is a unique integer between 1 and
C IDM1*JDIM, to be assigned to the horizontal edge of the rectangular
C mesh whose left end point has indices (I,J) and whose right end point
C has indices (I+1,J).  INE1 enumerates the IDM1*JDIM horizontal edges
C of the mesh, row by row, from bottom to top, and, within each row,
C from left to right.
C
        INE1(I,J)=(J-1)*IDM1+I
C
C The value of the function INE2(I,J) is a unique integer between
C IDM1*JDIM+1 and IDM1*JDIM+IDIM*JDM1, to be assigned to the vertical
C edge of the rectangular mesh whose bottom end point has indices (I,J)
C and whose top end point has indices (I,J+1).  INE2 enumerates the
C IDIM*JDM1 vertical edges of the mesh, row by row, from bottom to top,
C and, within each row, from left to right.
C
        INE2(I,J)=(J-1)*IDIM+I+IDM1*JDIM
C
C The value of the function INE3(I,J) is a unique integer between
C IDM1*JDIM+IDIM*JDM1+1 and IDM1*JDIM+IDIM*JDM1+IDM1*JDM1, to be
C assigned to a diagonal of the cell of the rectangular mesh with
C lower left corner at indices (I,J).  INE3 enumerates the IDM1*JDM1
C diagonal edges of the mesh, row by row, from bottom to top, and,
C within each row, from left to right.
C
        INE3(I,J)=(J-1)*IDM1+I+IDM1*JDIM+IDIM*JDM1
C
C The value of the function INTR(I,J,K) is a unique integer between 1
C and 2*IDM1*JDM1, to be assigned to triangle K (where K is a 1 or a 2)
C in the cell of the rectangular mesh with lower left corner at indices
C (I,J).  INTR enumerates the triangles of the mesh, row by row, from
C bottom to top; within each row, from left to right; and within each
C cell of the rectangular mesh, from one half to the other.
C
        INTR(I,J,K)=2*((J-1)*IDM1+I-1)+K
C
C Each of the functions IBPT(I,J), IBE1(I,J), IBE2(I,J), IBE3(I,J), and
C IBTR(I,J,K) generates the base index of a point node, an edge node,
C or a triangle node of a particular type.  In each case, we use the
C ordinal number of the node, minus one, times the length of the node.
C
        IBPT(I,J  )=(INPT(I,J  )-1)*LOPN
        IBE1(I,J  )=(INE1(I,J  )-1)*LOEN
        IBE2(I,J  )=(INE2(I,J  )-1)*LOEN
        IBE3(I,J  )=(INE3(I,J  )-1)*LOEN
        IBTR(I,J,K)=(INTR(I,J,K)-1)*LOTN
C
C
C C R E A T E   A   T R I A N G U L A R   M E S H ----------------------
C
C
C Define the points of the mesh.  There are IDIM points per row on each
C of JDIM rows.  The point with indices (I,J) in the rectangular mesh
C is assigned to the point node with base index IBPT(I,J).  Its X and Y
C coordinates are interpolated between XMIN and XMAX and between YMIN
C and YMAX, respectively, and it is given the data value defined by the
C function Z.
C
        DO 102 I=1,IDIM
          DO 101 J=1,JDIM
            IBIP=IBPT(I,J)
            RPNT(IBIP+1)=XMIN+(REAL(I-1)/REAL(IDM1))*(XMAX-XMIN)
            RPNT(IBIP+2)=YMIN+(REAL(J-1)/REAL(JDM1))*(YMAX-YMIN)
            RPNT(IBIP+3)=0.
            RPNT(IBIP+4)=Z(RPNT(IBIP+1),RPNT(IBIP+2))
  101     CONTINUE
  102   CONTINUE
C
C Define the edges of the mesh, each of which joins two adjacent points
C of it, in three groups.
C
C The first group of edges are horizontal; there are IDIM-1 per row on
C each of JDIM rows.  Each joins two points with rectangular indices
C (I,J) and (I+1,J), for some I in [1,IDIM-1] and some J in [1,JDIM],
C and is assigned to the edge node with base index IBE1(I,J).  Its first
C two elements are base indices of the points that it joins; its third
C and fourth elements indicate that there are no triangles to its left
C and right, respectively (which may change when we define the triangle
C list); and its fifth element is initialized to zero.
C
        DO 104 I=1,IDM1
          DO 103 J=1,JDIM
            IBIE=IBE1(I,J)
            IEDG(IBIE+1)=IBPT(I  ,J  )
            IEDG(IBIE+2)=IBPT(I+1,J  )
            IEDG(IBIE+3)=-1
            IEDG(IBIE+4)=-1
            IEDG(IBIE+5)=0
  103     CONTINUE
  104   CONTINUE
C
C The second group of edges are vertical; there are IDIM per row on
C each of JDIM-1 rows.  Each joins two points with rectangular indices
C (I,J) and (I,J+1), for some I in [1,IDIM] and some J in [1,JDIM-1],
C and is assigned to the edge node with base index IBE2(I,J).  Its first
C two elements are base indices of the points that it joins; its third
C and fourth elements indicate that there are no triangles to its left
C and right, respectively (which may change when we define the triangle
C list); and its fifth element is initialized to zero.
C
        DO 106 I=1,IDIM
          DO 105 J=1,JDM1
            IBIE=IBE2(I,J)
            IEDG(IBIE+1)=IBPT(I  ,J  )
            IEDG(IBIE+2)=IBPT(I  ,J+1)
            IEDG(IBIE+3)=-1
            IEDG(IBIE+4)=-1
            IEDG(IBIE+5)=0
  105     CONTINUE
  106   CONTINUE
C
C The third group of edges are diagonals; there are IDIM-1 per row on
C each of JDIM-1 rows.  Each joins two points with rectangular indices
C (I,J) and (I+1,J+1), if the sum of I and J is even, or (I,J+1) and
C (I+1,J), if the sum of I and J is odd, for some I in [1,IDIM-1] and
C some J in [1,JDIM-1], and is assigned to the edge node with base index
C IBE3(I,J).  Its first two elements are base indices of the points that
C it joins; its third and fourth elements indicate that there are no
C triangles to its left and right, respectively (which may change when
C we define the triangle list); and its fifth element is initialized to
C zero.  (Using different diagonals in a checkerboard fashion yields a
C more pleasant pattern to look at than always using the same diagonal
C would.)
C
        DO 108 I=1,IDM1
          DO 107 J=1,JDM1
            IBIE=IBE3(I,J)
            IF (MOD(I+J,2).EQ.0)
     +      THEN
C             diagonal is from lower left to upper right
              IEDG(IBIE+1)=IBPT(I  ,J  )
              IEDG(IBIE+2)=IBPT(I+1,J+1)
              IEDG(IBIE+3)=-1
              IEDG(IBIE+4)=-1
              IEDG(IBIE+5)=0
            ELSE
C             diagonal is from upper left to lower right
              IEDG(IBIE+1)=IBPT(I  ,J+1)
              IEDG(IBIE+2)=IBPT(I+1,J  )
              IEDG(IBIE+3)=-1
              IEDG(IBIE+4)=-1
              IEDG(IBIE+5)=0
            END IF
  107     CONTINUE
  108   CONTINUE
C
C Finally, we define the triangles of the mesh.  The following diagrams
C should be useful in understanding the code that follows:
C
C   CASE 1:  MOD(I+J,2)=0
C
C   +-----a-----+
C   |         . |   In this case, triangles 1 and 2 are in the lower
C   |  2    .   |   right and upper left corners of the rectangular
C   b     c     b   cell, respectively.  The edges of each are labeled
C   |   .    1  |   a (a horizontal edge), b (a vertical edge), and c
C   | .         |   (a diagonal edge).
C   +-----a-----+
C
C   CASE 2:  MOD(I+J,2)=1
C
C   +-----b-----+
C   | .         |   In this case, triangles 1 and 2 are in the lower
C   |   .    2  |   left and upper right corners of the rectangular
C   a     c     a   cell, respectively.  The edges of each are labeled
C   |  1    .   |   a (a vertical edge), b (a horizontal edge), and c
C   |         . |   (a diagonal edge).
C   +-----b-----+
C
C There are JDIM-1 rows of rectangles, with IDIM-1 rectangles in each
C row; each rectangle gives rise to two triangles.  A triangle node
C has the base index IBTR(I,J,K), where I and J specify the lower left
C corner of a cell of the rectangular mesh and K is 1 or 2 for the lower
C and upper triangles in the cell, respectively.  Elements 1, 2, and 3
C of the triangle node are base indices of the edge nodes for the edges
C of the triangle; these are arranged in the order "abc" to ensure that
C they are given in counterclockwise order, as required by CONPACKT.
C Element 4 of the triangle node is a zero, indicating that the triangle
C is not "blocked".  (Later, certain triangles will be blocked as an
C illustration of the capability.)
C
C As each triangle is defined, we also modify element 3 or element 4,
C as appropriate, in each of the edge nodes defining its edges so as
C to point back into the triangle node.  It becomes important, in doing
C this, to remember that the ordering of the points used to define the
C edges is such that the horizontal edges "point" from left to right,
C the vertical edges from bottom to top, and the diagonal edges from
C lower left to upper right (when K=1) or from upper left to lower
C right (when K=2); these conventions tell us whether a given triangle
C is to the left or to the right of a given edge.
C
C NOTE (03/07/2006): For procedural reasons, I needed to remove the
C exclamation-point comments from the following code.  That made the
C code much harder to follow, so I'm putting in two copies of it, the
C first of which has C's in column 1 and the second of which has the
C exclamation-point comments removed.
C
C Original version (easier to follow):
C
C       DO 111 I=1,IDM1
C         DO 110 J=1,JDM1
C           DO 109 K=1,2
C             IBIT=IBTR(I,J,K)
C             IF (MOD(I+J,2).EQ.0)
C    +        THEN ! diagonal is from lower left to upper right
C               IF (K.EQ.1) THEN ! lower right triangle
C                 ITRI(IBIT+1)=IBE1(I  ,J  )  ! edge a
C                 ITRI(IBIT+2)=IBE2(I+1,J  )  ! edge b
C                 ITRI(IBIT+3)=IBE3(I  ,J  )  ! edge c
C                 ITRI(IBIT+4)=0              ! triangle unblocked
C                 IEDG(ITRI(IBIT+1)+3)=IBIT+1 ! triangle left of edge a
C                 IEDG(ITRI(IBIT+2)+3)=IBIT+2 ! triangle left of edge b
C                 IEDG(ITRI(IBIT+3)+4)=IBIT+3 ! triangle right of edge c
C               ELSE                          ! upper left triangle
C                 ITRI(IBIT+1)=IBE1(I  ,J+1)  ! edge a
C                 ITRI(IBIT+2)=IBE2(I  ,J  )  ! edge b
C                 ITRI(IBIT+3)=IBE3(I  ,J  )  ! edge c
C                 ITRI(IBIT+4)=0              ! triangle unblocked
C                 IEDG(ITRI(IBIT+1)+4)=IBIT+1 ! triangle right of edge a
C                 IEDG(ITRI(IBIT+2)+4)=IBIT+2 ! triangle right of edge b
C                 IEDG(ITRI(IBIT+3)+3)=IBIT+3 ! triangle left of edge c
C               END IF
C             ELSE  !  diagonal is from upper left to lower right
C               IF (K.EQ.1) THEN              ! lower left triangle
C                 ITRI(IBIT+1)=IBE2(I  ,J  )  ! edge a
C                 ITRI(IBIT+2)=IBE1(I  ,J  )  ! edge b
C                 ITRI(IBIT+3)=IBE3(I  ,J  )  ! edge c
C                 ITRI(IBIT+4)=0              ! triangle unblocked
C                 IEDG(ITRI(IBIT+1)+4)=IBIT+1 ! triangle right of edge a
C                 IEDG(ITRI(IBIT+2)+3)=IBIT+2 ! triangle left of edge b
C                 IEDG(ITRI(IBIT+3)+4)=IBIT+3 ! triangle right of edge c
C               ELSE                          ! upper right triangle
C                 ITRI(IBIT+1)=IBE2(I+1,J  )  ! edge a
C                 ITRI(IBIT+2)=IBE1(I  ,J+1)  ! edge b
C                 ITRI(IBIT+3)=IBE3(I  ,J  )  ! edge c
C                 ITRI(IBIT+4)=0              ! triangle unblocked
C                 IEDG(ITRI(IBIT+1)+3)=IBIT+1 ! triangle left of edge a
C                 IEDG(ITRI(IBIT+2)+4)=IBIT+2 ! triangle right of edge b
C                 IEDG(ITRI(IBIT+3)+3)=IBIT+3 ! triangle left of edge c
C               END IF
C             END IF
C 109       CONTINUE
C 110     CONTINUE
C 111   CONTINUE
C
C Version with exclamation-point comments removed (for compiler):
C
        DO 111 I=1,IDM1
          DO 110 J=1,JDM1
            DO 109 K=1,2
              IBIT=IBTR(I,J,K)
              IF (MOD(I+J,2).EQ.0)
     +        THEN
                IF (K.EQ.1) THEN
                  ITRI(IBIT+1)=IBE1(I  ,J  )
                  ITRI(IBIT+2)=IBE2(I+1,J  )
                  ITRI(IBIT+3)=IBE3(I  ,J  )
                  ITRI(IBIT+4)=0
                  IEDG(ITRI(IBIT+1)+3)=IBIT+1
                  IEDG(ITRI(IBIT+2)+3)=IBIT+2
                  IEDG(ITRI(IBIT+3)+4)=IBIT+3
                ELSE
                  ITRI(IBIT+1)=IBE1(I  ,J+1)
                  ITRI(IBIT+2)=IBE2(I  ,J  )
                  ITRI(IBIT+3)=IBE3(I  ,J  )
                  ITRI(IBIT+4)=0
                  IEDG(ITRI(IBIT+1)+4)=IBIT+1
                  IEDG(ITRI(IBIT+2)+4)=IBIT+2
                  IEDG(ITRI(IBIT+3)+3)=IBIT+3
                END IF
              ELSE
                IF (K.EQ.1) THEN
                  ITRI(IBIT+1)=IBE2(I  ,J  )
                  ITRI(IBIT+2)=IBE1(I  ,J  )
                  ITRI(IBIT+3)=IBE3(I  ,J  )
                  ITRI(IBIT+4)=0
                  IEDG(ITRI(IBIT+1)+4)=IBIT+1
                  IEDG(ITRI(IBIT+2)+3)=IBIT+2
                  IEDG(ITRI(IBIT+3)+4)=IBIT+3
                ELSE
                  ITRI(IBIT+1)=IBE2(I+1,J  )
                  ITRI(IBIT+2)=IBE1(I  ,J+1)
                  ITRI(IBIT+3)=IBE3(I  ,J  )
                  ITRI(IBIT+4)=0
                  IEDG(ITRI(IBIT+1)+3)=IBIT+1
                  IEDG(ITRI(IBIT+2)+4)=IBIT+2
                  IEDG(ITRI(IBIT+3)+3)=IBIT+3
                END IF
              END IF
  109       CONTINUE
  110     CONTINUE
  111   CONTINUE
C
C The triangular mesh is complete.  For illustrative purposes, we will
C block some triangles (numbered 29, 30, 31, 32, 41, 42, 43, and 44) in
C the center of the mesh (but only when IDIM and JDIM are both 7, since
C these specific numbers are used for the triangles blocked).
C
        IF (IDIM.EQ.7.AND.JDIM.EQ.7) THEN
          ITRI(28*LOTN+4)=1
          ITRI(29*LOTN+4)=1
          ITRI(30*LOTN+4)=1
          ITRI(31*LOTN+4)=1
          ITRI(40*LOTN+4)=1
          ITRI(41*LOTN+4)=1
          ITRI(42*LOTN+4)=1
          ITRI(43*LOTN+4)=1
        END IF
C
C
C O P E N   A N D   I N I T I A L I Z E   G K S ------------------------
C
C
C Open GKS.
C
        CALL GOPKS (IERF,0)
        CALL GOPWK (IWID,LUNI,IWTY)
        CALL GACWK (IWID)
C
C Turn off the clipping indicator.
C
        CALL GSCLIP (0)
C
C Define a basic set of colors (0 = white, background; 1 = black,
C foreground; 2 = yellow; 3 = magenta; 4 = red; 5 = cyan; 6 = green;
C 7 = blue; 8 = a yellow for unblocked portions of the mesh; and 9 =
C a yellow for blocked portions of the mesh).
C
        CALL GSCR   (IWID, 0,1.,1.,1.)
        CALL GSCR   (IWID, 1,0.,0.,0.)
        CALL GSCR   (IWID, 2,1.,1.,0.)
        CALL GSCR   (IWID, 3,1.,0.,1.)
        CALL GSCR   (IWID, 4,1.,0.,0.)
        CALL GSCR   (IWID, 5,0.,1.,1.)
        CALL GSCR   (IWID, 6,0.,1.,0.)
        CALL GSCR   (IWID, 7,0.,0.,1.)
        CALL GSCR   (IWID, 8,.8,.8,0.)
        CALL GSCR   (IWID, 9,1.,1.,0.)
C
C Define 100 colors, associated with color indices 151 through 250, to
C be used for color-filled contour bands and in cell arrays, ranging
C from blue to red.
C
        CALL DFCLRS (IWID,151,250,0.,0.,1.,1.,0.,0.)
C
C
C S E T   I N T E R N A L   P A R A M E T E R S ------------------------
C
C
C Tell PLOTCHAR to use one of the filled fonts and to outline each
C character.
C
        CALL PCSETI ('FN',25)
        CALL PCSETI ('OF',1)
C
C Tell CONPACKT to use a smaller viewport, to match what is used in
C drawing the picture of the triangular mesh.
C
        CALL CTSETR ('VPL - VIEWPORT LEFT  ',.1)
        CALL CTSETR ('VPR - VIEWPORT RIGHT ',.9)
        CALL CTSETR ('VPB - VIEWPORT TOP   ',.1)
        CALL CTSETR ('VPT - VIEWPORT BOTTOM',.9)
C
C Tell CONPACKT to draw the mesh's outer boundary in red.
C
        CALL CTSETI ('PAI - PARAMETER ARRAY INDEX',-1)
        CALL CTSETI ('CLU - CONTOUR LEVEL USE FLAG',1)
        CALL CTSETI ('CLC - CONTOUR LEVEL COLOR INDEX',4)
C
C Tell CONPACKT to use bigger labels on contours drawn by the dash
C package and to put them a little closer together.
C
        CALL CTSETR ('DPS - DASH PATTERN SIZE (CHARACTERS)',.015)
        CALL CTSETR ('DPV - DASH PATTERN VECTOR LENGTH',.0025)
C
C
C D R A W   A   P I C T U R E   O F   T H E   M E S H ------------------
C
C
C The picture is drawn only if IDIM and JDIM are both 7, because it has
C some features specific to that case.
C
        IF (IDIM.NE.7.OR.JDIM.NE.7) GO TO 117
C
C Do a SET call enabling the use of the X and Y coordinates in the mesh.
C
        CALL SET    (.10,.90,.10,.90,XMIN,XMAX,YMIN,YMAX,1)
C
C Label the frame.
C
        CALL PLCHHQ (CFUX(.5),CFUY(.965),'Simple Triangular Mesh Derived
     + From Rectangular Mesh',.014,0.,0.)
C
        CALL PLCHHQ (CFUX(.5),CFUY(.940), 'The mesh is in yellow, with a
     + lighter shade where triangles are blocked.',.011,0.,0.)
C
        CALL PLCHHQ (CFUX(.5),CFUY(.033),'Point numbers are in blue; edg
     +e numbers, in green; triangle numbers, in red.',.011,0.,0.)
C
        CALL PLCHHQ (CFUX(.5),CFUY(.011), 'Triangles 29-32 and 41-44 are
     + blocked; no contours will be drawn there.',.011,0.,0.)
C
C Label the edges of the mesh.
C
        DO 112 I=1,IDIM
          WRITE (CTMP,'(''I='',I1)') I
          CALL PLCHMQ (XMIN+(REAL(I-1)/REAL(IDIM-1))*(XMAX-XMIN),
     +                 CFUY(CUFY(YMIN)-.040),
     +                 CTMP,.020,0.,0.)
  112   CONTINUE
C
        DO 113 J=1,JDIM
          WRITE (CTMP,'(''J='',I1)') J
          CALL PLCHMQ (CFUX(CUFX(XMIN)-.040),
     +                 YMIN+(REAL(J-1)/REAL(JDIM-1))*(YMAX-YMIN),
     +                 CTMP,.020,0.,1.)
  113   CONTINUE
C
C Draw the mesh in two shades of yellow, to distinguish blocked portions
C of it from unblocked portions.
C
        CALL DRWMSH (RPNT,NPNT,LOPN,
     +               IEDG,NEDG,LOEN,
     +               ITRI,NTRI,LOTN,
     +               8,9)
C
C Label the points of the mesh, in blue.
C
        CALL PLOTIT (0,0,2)
        CALL GSPLCI (7)
        CALL GSLWSC (2.)
C
        DO 114 IPTP=0,NPNT-LOPN,LOPN
          CALL LABLIT (IPTP/LOPN+1,.024,0.,RPNT(IPTP+1),RPNT(IPTP+2))
  114   CONTINUE
C
C Label the edges of the mesh, in green.
C
        CALL PLOTIT (0,0,2)
        CALL GSPLCI (6)
        CALL GSLWSC (2.)
C
        DO 115 IPTE=0,NEDG-LOEN,LOEN
          CALL LABLIT (IPTE/LOEN+1,.012,
     +                 ATAN2(RPNT(IEDG(IPTE+2)+2)-RPNT(IEDG(IPTE+1)+2),
     +                       RPNT(IEDG(IPTE+2)+1)-RPNT(IEDG(IPTE+1)+1)),
     +                   .5*(RPNT(IEDG(IPTE+1)+1)+RPNT(IEDG(IPTE+2)+1)),
     +                   .5*(RPNT(IEDG(IPTE+1)+2)+RPNT(IEDG(IPTE+2)+2)))
  115   CONTINUE
C
C Label the triangles of the mesh, in red.
C
        CALL PLOTIT (0,0,2)
        CALL GSPLCI (4)
        CALL GSLWSC (2.)
C
        DO 116 IPTT=0,NTRI-LOTN,LOTN
          CALL LABLIT (IPTT/LOTN+1,.018,0.,
     +                 (RPNT(IEDG(ITRI(IPTT+1)+1)+1)+
     +                  RPNT(IEDG(ITRI(IPTT+1)+2)+1)+
     +                  RPNT(IEDG(ITRI(IPTT+2)+1)+1)+
     +                  RPNT(IEDG(ITRI(IPTT+2)+2)+1)+
     +                  RPNT(IEDG(ITRI(IPTT+3)+1)+1)+
     +                  RPNT(IEDG(ITRI(IPTT+3)+2)+1))/6.,
     +                 (RPNT(IEDG(ITRI(IPTT+1)+1)+2)+
     +                  RPNT(IEDG(ITRI(IPTT+1)+2)+2)+
     +                  RPNT(IEDG(ITRI(IPTT+2)+1)+2)+
     +                  RPNT(IEDG(ITRI(IPTT+2)+2)+2)+
     +                  RPNT(IEDG(ITRI(IPTT+3)+1)+2)+
     +                  RPNT(IEDG(ITRI(IPTT+3)+2)+2))/6.)
  116   CONTINUE
C
        CALL PLOTIT (0,0,2)
        CALL GSPLCI (1)
        CALL GSLWSC (1.)
C
C Advance the frame.
C
        CALL FRAME
C
C
C D R A W   A   S I M P L E   C O N T O U R   P L O T ------------------
C
C
C Label the frame.
C
  117   CALL PLCHHQ (CFUX(.5),CFUY(.950), 'Contours on Triangular Mesh',
     +.018,0.,0.)
C
C Initialize CONPACKT.
C
        CALL CTMESH (RPNT,NPNT,LOPN,
     +               IEDG,NEDG,LOEN,
     +               ITRI,NTRI,LOTN,
     +               RWRK,LRWK,
     +               IWRK,LIWK)
C
C Draw the mesh in two shades of yellow, to distinguish blocked portions
C of it from unblocked portions.
C
        CALL DRWMSH (RPNT,NPNT,LOPN,
     +               IEDG,NEDG,LOEN,
     +               ITRI,NTRI,LOTN,
     +               8,9)
C
C Draw contour lines with labels written by the dash package.
C
        CALL CTCLDR (RPNT,IEDG,ITRI,RWRK,IWRK)
C
C Add informational and high/low labels.
C
        CALL CTLBDR (RPNT,IEDG,ITRI,RWRK,IWRK)
C
C Advance the frame.
C
        CALL FRAME
C
C
C D R A W   A   C O L O R - F I L L E D   C O N T O U R   P L O T ------
C
C
C Label the frame.
C
        CALL PLCHHQ (CFUX(.5),CFUY(.950), 'Colored Contour Bands on Tria
     +ngular Mesh',.018,0.,0.)
C
C Initialize an area map.
C
        CALL ARINAM (IAMA,LAMA)
C
C Put contour lines in the area map.
C
        CALL CTCLAM (RPNT,IEDG,ITRI,RWRK,IWRK,IAMA)
C
C Scan the area map and deliver the areas defined by it to the routine
C DCFOCB.
C
        CALL ARSCAM (IAMA,XCRA,YCRA,NCRA,IAAI,IAGI,NGPS,DCFOCB)
C
C Advance the frame.
C
        CALL FRAME
C
C
C C L O S E   G K S   A N D   Q U I T ----------------------------------
C
C
C Close GKS.
C
        CALL GDAWK (IWID)
        CALL GCLWK (IWID)
        CALL GCLKS
C
C Done.
C
        STOP
C
      END

      SUBROUTINE DFCLRS (IWID,IOFC,IOLC,REDF,GRNF,BLUF,REDL,GRNL,BLUL)
C
C This routine defines color indices IOFC through IOLC on workstation
C IWID by interpolating values from REDF/GRNF/BLUF to REDL/GRNL/BLUL.
C
        DO 101 I=IOFC,IOLC
          P=REAL(IOLC-I)/REAL(IOLC-IOFC)
          Q=REAL(I-IOFC)/REAL(IOLC-IOFC)
          CALL GSCR (IWID,I,P*REDF+Q*REDL,P*GRNF+Q*GRNL,P*BLUF+Q*BLUL)
  101   CONTINUE
C
C Done.
C
        RETURN
C
      END

      SUBROUTINE DRWMSH (RPNT,NPNT,LOPN,
     +                   IEDG,NEDG,LOEN,
     +                   ITRI,NTRI,LOTN,
     +                   ICI1,ICI2)
C
        DIMENSION RPNT(NPNT),IEDG(NEDG),ITRI(NTRI)
C
C Draw the edges of the triangular mesh defined by the arguments.  Use
C color index ICI1 to draw edges in areas that are unblocked and color
C index ICI2 to draw edges in areas that are blocked.
C
        DO 101 IPTE=0,NEDG-LOEN,LOEN
C
          IFLL=0
C
          IF (IEDG(IPTE+3).GE.0) THEN
            IF (ITRI(LOTN*((IEDG(IPTE+3)-1)/LOTN)+4).EQ.0) IFLL=1
          END IF
C
          IFLR=0
C
          IF (IEDG(IPTE+4).GE.0) THEN
            IF (ITRI(LOTN*((IEDG(IPTE+4)-1)/LOTN)+4).EQ.0) IFLR=1
          END IF
C
          IF (IFLL.NE.0.OR.IFLR.NE.0) THEN
            CALL PLOTIT (0,0,2)
            CALL GSPLCI (ICI1)
          ELSE
            CALL PLOTIT (0,0,2)
            CALL GSPLCI (ICI2)
          END IF
C
          CALL LINE   (RPNT(IEDG(IPTE+1)+1),RPNT(IEDG(IPTE+1)+2),
     +                 RPNT(IEDG(IPTE+2)+1),RPNT(IEDG(IPTE+2)+2))
C
  101   CONTINUE
C
        CALL PLOTIT (0,0,2)
        CALL GSPLCI (1)
C
        RETURN
C
      END

      SUBROUTINE LABLIT (INUM,SIZE,ANGR,XPOS,YPOS)
C
        CHARACTER*8 CNUM
C
C Generate a label expressing the value of the integer INUM and place it
C on the frame at the position (XPOS,YPOS) in the current user system,
C using characters of size SIZE (in the fractional coordinate system),
C and an angle of ANGR (in radians).
C
C Conversion factor, radians to degrees.
C
        DATA RTOD / 57.2957795130823 /
C
C Encode the integer into CNUM.
C
        WRITE (CNUM,'(I8)') INUM
C
C Write the label and return.  The loop finds the first non-blank in the
C label so that we can use sub-string notation in the call to PLCHMQ.
C
        DO 101 I=1,8
          IF (CNUM(I:I).NE.' ') THEN
            CALL PLCHMQ (XPOS,YPOS,CNUM(I:8),SIZE,RTOD*ANGR,0.)
            RETURN
          END IF
  101   CONTINUE
C
C If no non-blank character is found, return, having done nothing.
C
        RETURN
C
      END

      SUBROUTINE DCFOCB (XCRA,YCRA,NCRA,IAAI,IAGI,NGPS)
C
C This routine fills the area defined by the points (XCRA(I),YCRA(I)),
C for I = 1 to NCRA, if and only if none of the area identifiers for
C the area are negative.  The color used is determined from the area
C identifier of the area relative to group 3; we assume that 100 colors
C are defined having color indices 151 through 250 and interpolate to
C determine which of these colors to use.
C
        DIMENSION XCRA(*),YCRA(*),IAAI(*),IAGI(*)
C
C Retrieve the number of contour levels being used.
C
        CALL CTGETI ('NCL - NUMBER OF CONTOUR LEVELS',NOCL)
C
C If the number of contour levels is non-zero and the area has more
C than two points, fill it.
C
        IF (NOCL.NE.0.AND.NCRA.GT.2) THEN
C
          IAI3=-1
C
          DO 101 I=1,NGPS
            IF (IAGI(I).EQ.3) IAI3=IAAI(I)
  101     CONTINUE
C
          IF (IAI3.GE.1.AND.IAI3.LE.NOCL+1) THEN
            CALL GSFACI (151+INT(((REAL(IAI3)-.5)/REAL(NOCL+1))*100.))
            CALL GFA    (NCRA,XCRA,YCRA)
          ELSE IF (IAI3.EQ.1001) THEN
            CALL GSFACI (2)
            CALL GFA    (NCRA,XCRA,YCRA)
          ELSE IF (IAI3.EQ.1002) THEN
            CALL GSFACI (3)
            CALL GFA    (NCRA,XCRA,YCRA)
          END IF
C
        END IF
C
C Done.
C
        RETURN
C
      END


c-----------------------------------------------------------------------
c
c  Natural pressure boundary condition can be calculated with p, the pressure,
c  related (in some prescribed manner) to Q, the flow rate, through the same
c  boundary.  To do this efficiently requires us to precompute the integral
c  of N_A over the boundary for each node A and store it in a vector of length
c  nshg (a bit wasteful since only the nodes on the boundary will be non zero
c  in this vector but it is probably slower to index it than to multiply and
c  add the extra zeros....check later).
c
c-----------------------------------------------------------------------
      module pvsQbi

      real*8, allocatable ::  NABI(:,:)
      real*8, allocatable ::  NASC(:)
      integer, allocatable :: ndsurf(:)

      end module

c-----------------------------------------------------------------------
c
c     Initialize:
c
c-----------------------------------------------------------------------
      subroutine initNABI( x, shpb )

      use     pointer_data
      use     pvsQbi
      include "common.h"

      real*8   x(numnp,nsd)
c
c use is like
c
c      NABI=pvsQbi -> NABI
c
        dimension   shpb(MAXTOP,maxsh,MAXQPT)
        real*8, allocatable :: tmpshpb(:,:)
        allocate ( NABI(nshg,3) )
        allocate ( NASC(nshg)   )
        allocate ( ndsurf(nshg) )

c
c....  calculate NABI
c
      NABI=zero
      NASC=zero
      ndsurf=0
c
c.... -------------------->   boundary elements   <--------------------
c
c.... set up parameters
c
c        intrul = intg   (2,itseq)
c        intind = intptb (intrul)
c
c.... loop over the boundary elements
c
        do iblk = 1, nelblb
c
c.... set up the parameters
c
          iel    = lcblkb(1,iblk)
          lelCat = lcblkb(2,iblk)
          lcsyst = lcblkb(3,iblk)
          iorder = lcblkb(4,iblk)
          nenl   = lcblkb(5,iblk)  ! no. of vertices per element
          nenbl  = lcblkb(6,iblk)  ! no. of vertices per bdry. face
          nshl   = lcblkb(9,iblk)
          nshlb  = lcblkb(10,iblk)
          mattyp = lcblkb(7,iblk)
          ndofl  = lcblkb(8,iblk)
          npro   = lcblkb(1,iblk+1) - iel

          if(lcsyst.eq.3) lcsyst=nenbl
c
          if(lcsyst.eq.3 .or. lcsyst.eq.4) then
             ngaussb = nintb(lcsyst)
          else
             ngaussb = nintb(lcsyst)
          endif

c
c.... compute and assemble the residuals corresponding to the
c     boundary integral
c
          allocate (tmpshpb(nshl,MAXQPT))

          tmpshpb(1:nshl,:) = shpb(lcsyst,1:nshl,:)

          call AsBNABI (                       x,
     &                 tmpshpb,
     &                 mienb(iblk)%p,
     &                 miBCB(iblk)%p)

          call AsBNASC(                       x,
     &                 tmpshpb,
     &                 mienb(iblk)%p,
     &                 miBCB(iblk)%p)

          deallocate (tmpshpb)

      enddo

c
c     note that NABI has NOT been communicated.  It
C     is the on processor contribution to this vector.  It will used to
C     build the on processor contribution to res that will then be made
C     complete via a call to commu.  Similarly the LHS usage will create
C     the on-processor contribution to the lhsK. Same for NASC
c
      return
      end


program stripack_prb2
!
!*******************************************************************************
!
!! STRIPACK_PRB2 demonstrates how to use STRIPACK data.
!
!
!  Discussion:
!
!    STRIPACK can compute the Voronoi diagram for data on a sphere.
!
!    This routine has STRIPACK compute the Voronoi diagram, then
!    takes just a few of the "interesting" arrays, and uses them
!    to visit every Voronoi polygon.  Just to prove that is what
!    we are doing, we compute the area of each subtriangle of the
!    polygons, and sum them.  This should be equal to the total area
!    of the sphere, 4 * PI.
!
  implicit none
!
  integer, parameter :: nmax = 9000
  integer            :: n,i
!
  double precision d_pi
  integer lend(nmax)
  integer listc(6*(nmax-2))
  integer lptr(6*(nmax-2))
  double precision sphere_area
  double precision x(nmax)
  double precision parea(nmax)
  double precision xc(2*(nmax-2))
  double precision y(nmax)
  double precision yc(2*(nmax-2))
  double precision z(nmax),xs,ys,zs
  double precision zc(2*(nmax-2))
!
  call timestamp ( )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'STRIPACK_PRB2'
  write ( *, '(a)' ) '  A sample application of the data produced by'
  write ( *, '(a)' ) '  STRIPACK.  Here, we have STRIPACK compute the'
  write ( *, '(a)' ) '  Voronoi diagram of a set of points on the unit'
  write ( *, '(a)' ) '  sphere, and then we do a simple check by computing'
  write ( *, '(a)' ) '  the polygonal area and summing.'

  !call random_number ( harvest = x(1:n) )
  !call random_number ( harvest = y(1:n) )
  !call random_number ( harvest = z(1:n) )
  open(97,file="isoave.coords49",form='formatted')
  read(97,*) n
  print *,'Number of nodes: ',n
  do i=1,n
     read(97,*) x(i),y(i),z(i)
  enddo
  close(97)

! first 3 points must not be on a great circle.
! swap 2 and 6
  xs=x(2)
  ys=y(2)
  zs=z(2)
  x(2)=x(6)
  y(2)=y(6)
  z(2)=z(6)
  x(6)=xs
  y(6)=ys
  z(6)=zs

  call d3vec_normalize ( n, x, y, z )

  call voronoi_get ( n, x, y, z, xc, yc, zc, lend, listc, lptr )

  call voronoi_poly_count ( n, lend, lptr, listc )

  call voronoi_traverse ( n, x, y, z, xc, yc, zc, lend, listc, lptr, &
    sphere_area,parea )

  ! we swapped poitns 2 and 6 above, so swap areas back:
  xs=parea(2)
  parea(2)=parea(6)
  parea(6)=xs

  write ( *, '(a)' ) ' '
  write ( *, '(a,f12.6)' ) &
    '  Sphere area from Voronoi polygons =  ', sphere_area
  write ( *, '(a,f12.6)' ) &
    '  Exact area from spherical geometry = ', 4.0E+00 * d_pi ( )

  open(97,file="isoave.weights",form='formatted')
  do i=1,n
     write(97,*) parea(i)
  enddo
  stop
end
subroutine voronoi_get ( n, x, y, z, xc, yc, zc, lend, listc, lptr )
!
!*******************************************************************************
!
!! VORONOI_GET calls STRIPACK routines to get Voronoi information.
!
!
!  Modified:
!
!    25 June 2002
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer N, the number of points.
!
!    Input, double precision X(N), Y(N), Z(N), the coordinates of points
!    on the sphere.
!
!    Output, double precision XC(6*(N-2)), YC(6*(N-2)), ZC(6*(N-2)), the
!    coordinates of the vertices.
!
!    Output, integer LEND(N), points to the "first" vertex in the
!    Voronoi polygon around a particular node.
!
!    Output, integer LPTR(6*(N-2)), given a vertex, returns the next
!    vertex in the Voronoi polygon.  (The vertex numbering is done
!    in such a way that the physical vertex has three distince indices,
!    depending on which polygon we are considering.  Thus, it is always
!    possible to answer the question "which is the next vertex from this
!    one?" because the vertex index also tells us what polygon we are in.)
!
  implicit none
!
  integer n
  integer, parameter :: nrow = 9
!
  double precision ds(n)
  integer i
  integer ierror
  integer iwk(2*n)
  integer lbtri(6,n)
  integer lend(n)
  integer list(6*(n-2))
  integer listc(6*(n-2))
  integer lnew
  integer lptr(6*(n-2))
  integer ltri(nrow,2*(n-2))
  integer nb
  double precision norm
  integer nt
  double precision rc(2*(n-2))
  double precision x(n)
  double precision xc(2*(n-2))
  double precision y(n)
  double precision yc(2*(n-2))
  double precision z(n)
  double precision zc(2*(n-2))
!
!  Create the triangulation.
!
  call trmesh ( n, x, y, z, list, lptr, lend, lnew, iwk, iwk(n+1), ds, ierror )

  if ( ierror == -2 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'VORONOI_GET - Fatal error!'
    write ( *, '(a)' ) '  Error in TRMESH.'
    write ( *, '(a)' ) '  The first 3 nodes are collinear.'
    stop
  end if

  if ( ierror > 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'VORONOI_GET - Fatal error!'
    write ( *, '(a)' ) '  Error in TRMESH.'
    write ( *, '(a)' ) '  Duplicate nodes encountered.'
    stop
  end if
!
!  Create a triangle list.
!
  call trlist ( n, list, lptr, lend, nrow, nt, ltri, ierror )

  if ( ierror /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'VORONOI_GET - Fatal error!'
    write ( *, '(a)' ) '  Error in TRLIST.'
    stop
  end if
!
!  Construct the Voronoi diagram.
!
!  Note that the triangulation data structure is altered if NB > 0.
!
  call crlist ( n, n, x, y, z, list, lend, lptr, lnew, &
    lbtri, listc, nb, xc, yc, zc, rc, ierror )

  if ( ierror /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'VORONOI_GET - Fatal error!'
    write ( *, '(a)' ) '  Error in CRLIST.'
    write ( *, '(a,i6)' ) '  IERROR = ', ierror
    stop
  end if

  return
end
subroutine voronoi_traverse ( n, x, y, z, xc, yc, zc, lend, listc, lptr, &
  area_sphere, parea )
!
!*******************************************************************************
!
!! VORONOI_TRAVERSE traverses the polygons in a Voronoi diagram.
!
!
!  Discussion:
!
!    STRIPACK defines a data structure recording the location of
!    the vertices of the Voronoi diagram, and their connectivity.
!    The purpose of this routine is to "visit" each polygon, and,
!    in fact, each subtriangle of each polygon.  Such a procedure
!    would be done when estimating an integral by quadrature, for instance.
!
!  Modified:
!
!    25 June 2002
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer N, the number of nodes, and Voronoi polygons.
!
!    Input, double precision X(N), Y(N), Z(N), the coordinates of the nodes.
!
!    Input, double precision XC(6*(N-2)), YC(6*(N-2)), ZC(6*(N-2)), the
!    coordinates of the vertices.
!
!    Input, integer LEND(N), points to the "first" vertex in the
!    Voronoi polygon around a particular node.
!
!    Input, integer LPTR(6*(N-2)), given a vertex, returns the next
!    vertex in the Voronoi polygon.  (The vertex numbering is done
!    in such a way that the physical vertex has three distince indices,
!    depending on which polygon we are considering.  Thus, it is always
!    possible to answer the question "which is the next vertex from this
!    one?" because the vertex index also tells us what polygon we are in.)
!
!    Output, double precision AREA_SPHERE, the area of the sphere.
!    This is computed simply to demonstrate how the data structure is used.
!    It's assumed the sphere has radius 1, so the area should be
!    4 * PI * R**2 = 12.5664.
!
  implicit none
!
  integer n
!
  double precision area_polygon
  double precision area_sphere
  double precision area_triangle
  double precision areas
  double precision parea(n)
  integer lend(n)
  integer listc(6*(n-2))
  integer lptr(6*(n-2))
  integer node
  integer node_last
  integer node_new
  integer node_stop
  double precision r
  double precision v1(3)
  double precision v2(3)
  double precision v3(3)
  integer vertex_last
  integer vertex_new
  double precision x(n)
  double precision xc(6*(n-2))
  double precision y(n)
  double precision yc(6*(n-2))
  double precision z(n)
  double precision zc(6*(n-2))
!
  area_sphere = 0.0E+00

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'VORONOI_TRAVERSE'
  write ( *, '(a)' ) '  Visit each Voronoi polygon.'
  write ( *, '(a)' ) '  Compute the (spherical) area of each subtriangle'
  write ( *, '(a)' ) '  Add up to get the area of each polygon.'
  write ( *, '(a)' ) '  Output the areas to isoave.weights'
!
!  To access every polygon, start by accessing a particular node.
!
!  The Voronoi polygon around a node NODE has a pointer LEND(NODE) to the
!  first (or last) vertex of the Voronoi polygon around NODE.
!
!  To access all the vertices of the polygon in order, start at the
!  special vertex, and then repeatedly use the LPTR array to get the
!  next vertex on the polygon.  Stop when you return to LEND(NODE).
!
!  To subdivide the polygon into triangles, use NODE, VERTEX_LAST,
!  and VERTEX.
!
!  To get the coordinates of these points:
!
!    NODE ==>        X(NODE),         Y(NODE),         Z(NODE).
!
!    VERTEX_LAST ==> XC(VERTEX_LAST), YC(VERTEX_LAST), ZC(VERTEX_LAST)
!    VERTEX      ==> XC(VERTEX     ), YC(VERTEX     ), ZC(VERTEX     )
!
  area_sphere = 0.0E+00

  do node = 1, n

    area_polygon = 0.0E+00

!    write ( *, '(a)' ) ' '

    node_stop = lend(node)

    node_new = node_stop

    vertex_new = listc(node_new)
!
!  Each iteration of this DO walks along one side of the polygon,
!  considering the subtriangle NODE --> VERTEX_LAST --> VERTEX.
!
    do

      node_last = node_new
      node_new = lptr(node_last)

      vertex_last = vertex_new
      vertex_new = listc(node_new)
!
!  Here is a good place to process information about the polygon side
!
!   VERTEX_LAST --> VERTEX
!
!  or about the subtriangle
!
!   NODE --> VERTEX_LAST --> VERTEX.
!
      r = 1.0E+00
      v1(1:3) = (/ x(node),         y(node),         z(node)         /)
      v2(1:3) = (/ xc(vertex_last), yc(vertex_last), zc(vertex_last) /)
      v3(1:3) = (/ xc(vertex_new),  yc(vertex_new),  zc(vertex_new)      /)

      area_triangle = areas ( v1, v2, v3 )

      area_polygon = area_polygon + area_triangle

 !     write ( *, '(10x,g14.6)' ) area_triangle
!
!  Now if we have reached the vertex where we started, we are done with
!  this polygon.
!
      if ( node_new == node_stop ) then
        exit
      end if

    end do

   write ( *, '(i2,g14.6)' ) node, area_polygon
   parea(node)=area_polygon/(4*4*atan(1d0))

    area_sphere = area_sphere + area_polygon

  end do

  return
end


!
! ---------------------------------------------------------------------
! "THE BEER-WARE LICENSE" (Revision 42):
! CfKu wrote this file. As long as you retain this notice you can do
! whatever you want with this stuff. If we meet some day, and you
! think this stuff is worth it, you can buy me a beer in return.
! Christof Kuestner
! ---------------------------------------------------------------------
!
!######################################################################!
!#### COMMON_MATH MODULE                                               !
!####                                                                  !
!######################################################################!
! Version | Date            | Creator    | Comment                     !
!######################################################################!
! 1.0     | 2012-02-22      | CfKu       | First release               !
!######################################################################!
      MODULE comMath
      USE comSub
      IMPLICIT NONE

!######################################################################!
      !Overload round
      INTERFACE round
         module procedure round_scalar
         module procedure round_vec
         module procedure round_mat
      END INTERFACE

      !Overload trace
      INTERFACE tr
         module procedure trace_int
         module procedure trace_double
      END INTERFACE

      !Overload extract
      INTERFACE extract
         module procedure extract3_6x1_t2f
         module procedure extract3_6x6_t4f
      END INTERFACE

      !Overload contract
      INTERFACE contract
         module procedure contract3_t2f_6x1
         module procedure contract3_t4f_6x6
      END INTERFACE

      !Overload spectral representation
      INTERFACE spec
         module procedure spectral_ord2
      END INTERFACE

      !Overload in1 (first inner product)
      INTERFACE in1
         module procedure in1_ord11
         module procedure in1_ord12
         module procedure in1_ord21
         module procedure in1_ord22
         module procedure in1_ord222
      END INTERFACE

      !Overload in2 (second inner product)
      INTERFACE in2
         module procedure in2_ord22
         module procedure in2_ord24
         module procedure in2_ord42
         module procedure in2_ord44
         module procedure in2_ord444
      END INTERFACE

      !Overload dyad (outer product / dyadic product)
      INTERFACE dyad
         module procedure dyad_ord11
         module procedure dyad_ord22
      END INTERFACE

      !Overload inv (matrix inversion)
      INTERFACE inv_sym
         module procedure inv_6x6_sym
      END INTERFACE

!######################################################################!
      CONTAINS
!######################################################################!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION round_scalar(fNumb, iDigits) RESULT(res)
      ! rounds fNumb to iDigits decimal digits (scalar)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         REAL(8), INTENT(IN)  :: fNumb
         INTEGER, INTENT(IN)  :: iDigits
         REAL(8)  :: res

         !### VAR ###!
         integer :: iMulDiv

         !### CODE ###!
         iMulDiv = 10 ** iDigits
         res = REAL(INT(fNumb * iMulDiv + 0.5d0),8) / iMulDiv

      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION round_vec(vfNumb, iDigits) RESULT(res)
      ! rounds vfNumb to iDigits decimal digits (vector)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         REAL(8), INTENT(IN)  :: vfNumb(:)
         INTEGER, INTENT(IN)  :: iDigits
         REAL(8)  :: res(size(vfNumb,1))

         !### VAR ###!
         integer :: iMulDiv

         !### CODE ###!
         iMulDiv = 10 ** iDigits
         res = REAL(INT(vfNumb * iMulDiv + 0.5d0),8) / iMulDiv

      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION round_mat(afNumb, iDigits) RESULT(res)
      ! rounds afNumb to iDigits decimal digits (vector)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         REAL(8), INTENT(IN)  :: afNumb(:,:)
         INTEGER, INTENT(IN)  :: iDigits
         REAL(8)  :: res(size(afNumb,1),size(afNumb,2))

         !### VAR ###!
         !### VAR ###!
         integer :: iMulDiv

         !### CODE ###!
         iMulDiv = 10 ** iDigits
         res = REAL(INT(afNumb * iMulDiv + 0.5d0),8) / iMulDiv

      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION unit2(iDm) RESULT(res)
      ! returns an 2nd order unit tensor of dimension iDm (double)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN) :: iDm
         REAL(8)             :: res (iDm,iDm)

         !### VAR ###!
         integer :: i

         !### CODE ###!
         res = 0.0d0
         do i = 1,iDm
            res(i,i) = 1.0d0
         enddo

      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION unit4 (iDm) RESULT(res)
      ! returns the 4th order symetric unit tensor of dimension iDm (double)
      ! res_ijkl = delta_ik * delta_jl
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8)              :: res (iDm,iDm,iDm,iDm)

         !### VAR ###!
         integer  :: i,j,k,l
         real(8)  :: t2f_u2(iDm,iDm)

         !### CODE ###!
         t2f_u2 = unit2(iDm)
         do l = 1,iDm
            do k = 1,iDm
               do j = 1,iDm
                  do i = 1,iDm
                     res(i,j,k,l) = t2f_u2(i,k) * t2f_u2(j,l)
                  enddo
               enddo
            enddo
         enddo

      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION unit4_sym (iDm) RESULT(res)
      ! returns the 4th order symetric unit tensor of dimension iDm (double)
      ! res_ijkl = 0.5 * ( delta_ik * delta_jl + delta_jk * delta_il )
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8)              :: res (iDm,iDm,iDm,iDm)

         !### VAR ###!
         integer  :: i,j,k,l
         real(8)  :: t2f_u2(iDm,iDm)

         !### CODE ###!
         t2f_u2 = unit2(iDm)
         do l = 1,iDm
            do k = 1,iDm
               do j = 1,iDm
                  do i = 1,iDm
                     res(i,j,k,l) = 0.5d0 * ( t2f_u2(i,k) * t2f_u2(j,l)
     *                  + t2f_u2(j,k) * t2f_u2(i,l) )
                  enddo
               enddo
            enddo
         enddo

      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION kronckerdelta (iDm1,iDm2) RESULT(res)
      ! returns the kronecker delta
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN) :: iDm1, iDm2
         REAL(8)             :: res

         !### VAR ###!

         !### CODE ###!
         if (iDm1 == iDm2) then
            res = 1.0d0
         else
            res = 0.0d0
         endif

      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION levicivita (iDmI,iDmJ,iDmK,iDmL) RESULT(res)
      ! returns the Levi-Civita-Symbol (permutation symbol)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)           :: iDmI, iDmJ, iDmK
         INTEGER, INTENT(IN), OPTIONAL :: iDmL
         REAL(8)                       :: res

         !### VAR ###!

         !### CODE ###!
         if (present(iDmL)) then
            res = (1.0d0 / 12.0d0) *
     *         (iDmI - iDmJ) * (iDmI - iDmK) *
     *         (iDmI - iDmL) * (iDmJ - iDmK) *
     *         (iDmJ - iDmL) * (iDmK - iDmL)
         else
            res = 0.5d0 * (iDmI - iDmJ) * (iDmJ - iDmK) * (iDmK - iDmI)
         endif

      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION spectral_ord2 (vfEW,afEV) RESULT(res)
      ! spectral representation with vfEW (eigenvalues) and afEV (eigenvectors)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         REAL(8), INTENT(IN)  :: vfEW(3)
         REAL(8), INTENT(IN)  :: afEV(3,3)
         REAL(8)              :: res(3,3)

         !### VAR ###!
         integer  :: i
         real(8)  :: t2f_EVbases (3,3)

         !### CODE ###!
         res = 0.0d0
         do i = 1,3
            call dyad(t2f_EVbases, afEV(:,i), afEV(:,i),3)
            res = res + vfEW(i) * t2f_EVbases
         enddo

      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION trace_int (afMat) RESULT(res)
      ! returns the the trace of afMat [INTEGER]
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: afMat(:,:)
         INTEGER              :: res

         !### VAR ###!
         integer  :: i

         !### CODE ###!
         res = 0
         do i=1,min(size(afMat,1), size(afMat,2))
            res = res + afMat(i,i)
         enddo

      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION trace_double (afMat) RESULT(res)
      ! returns the the trace of afMat [DOUBLE]
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         REAL(8), INTENT(IN)  :: afMat(:,:)
         REAL(8)              :: res

         !### VAR ###!
         integer  :: i

         !### CODE ###!
         res = 0.0d0
         do i=1,min(size(afMat,1), size(afMat,2))
            res = res + afMat(i,i)
         enddo
      END FUNCTION

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE extract3_6x1_t2f (res, vfVec)
      ! extracts a 6x1 vector: res(3x3) = vfVec(6) [3rd dimension]
      !     vfVec          Vector; Dimension (6)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         REAL(8), INTENT(OUT) :: res (3,3)
         REAL(8), INTENT(IN)  :: vfVec (6)

         !### VAR ###!

         !### CODE ###!
         res(1,1) = vfVec(1)
         res(2,1) = vfVec(4)
         res(3,1) = vfVec(6)

         res(1,2) = vfVec(4)
         res(2,2) = vfVec(2)
         res(3,2) = vfVec(5)

         res(1,3) = vfVec(6)
         res(2,3) = vfVec(5)
         res(3,3) = vfVec(3)
      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE extract3_6x6_t4f (res, afMat)
      ! extracts a 6x1 vector: res(3x3x3x3) = afMat(6x6) [3rd dimension]
      !     afMat          Matrix; Dimension (6x6)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         REAL(8), INTENT(OUT) :: res (3,3,3,3)
         REAL(8), INTENT(IN)  :: afMat (6,6)

         !### VAR ###!

         !### CODE ###!
         res(1,1,1,1) = afMat(1,1)
         res(2,1,1,1) = afMat(4,1)
         res(3,1,1,1) = afMat(6,1)
         res(1,2,1,1) = afMat(4,1)
         res(2,2,1,1) = afMat(2,1)
         res(3,2,1,1) = afMat(5,1)
         res(1,3,1,1) = afMat(6,1)
         res(2,3,1,1) = afMat(5,1)
         res(3,3,1,1) = afMat(3,1)

         res(1,1,2,1) = afMat(1,4)
         res(2,1,2,1) = afMat(4,4)
         res(3,1,2,1) = afMat(6,4)
         res(1,2,2,1) = afMat(4,4)
         res(2,2,2,1) = afMat(2,4)
         res(3,2,2,1) = afMat(5,4)
         res(1,3,2,1) = afMat(6,4)
         res(2,3,2,1) = afMat(5,4)
         res(3,3,2,1) = afMat(3,4)

         res(1,1,3,1) = afMat(1,6)
         res(2,1,3,1) = afMat(4,6)
         res(3,1,3,1) = afMat(6,6)
         res(1,2,3,1) = afMat(4,6)
         res(2,2,3,1) = afMat(2,6)
         res(3,2,3,1) = afMat(5,6)
         res(1,3,3,1) = afMat(6,6)
         res(2,3,3,1) = afMat(5,6)
         res(3,3,3,1) = afMat(3,6)

         res(1,1,1,2) = afMat(1,4)
         res(2,1,1,2) = afMat(4,4)
         res(3,1,1,2) = afMat(6,4)
         res(1,2,1,2) = afMat(4,4)
         res(2,2,1,2) = afMat(2,4)
         res(3,2,1,2) = afMat(5,4)
         res(1,3,1,2) = afMat(6,4)
         res(2,3,1,2) = afMat(5,4)
         res(3,3,1,2) = afMat(3,4)

         res(1,1,2,2) = afMat(1,2)
         res(2,1,2,2) = afMat(4,2)
         res(3,1,2,2) = afMat(6,2)
         res(1,2,2,2) = afMat(4,2)
         res(2,2,2,2) = afMat(2,2)
         res(3,2,2,2) = afMat(5,2)
         res(1,3,2,2) = afMat(6,2)
         res(2,3,2,2) = afMat(5,2)
         res(3,3,2,2) = afMat(3,2)

         res(1,1,3,2) = afMat(1,5)
         res(2,1,3,2) = afMat(4,5)
         res(3,1,3,2) = afMat(6,5)
         res(1,2,3,2) = afMat(4,5)
         res(2,2,3,2) = afMat(2,5)
         res(3,2,3,2) = afMat(5,5)
         res(1,3,3,2) = afMat(6,5)
         res(2,3,3,2) = afMat(5,5)
         res(3,3,3,2) = afMat(3,5)

         res(1,1,1,3) = afMat(1,6)
         res(2,1,1,3) = afMat(4,6)
         res(3,1,1,3) = afMat(6,6)
         res(1,2,1,3) = afMat(4,6)
         res(2,2,1,3) = afMat(2,6)
         res(3,2,1,3) = afMat(5,6)
         res(1,3,1,3) = afMat(6,6)
         res(2,3,1,3) = afMat(5,6)
         res(3,3,1,3) = afMat(3,6)

         res(1,1,2,3) = afMat(1,5)
         res(2,1,2,3) = afMat(4,5)
         res(3,1,2,3) = afMat(6,5)
         res(1,2,2,3) = afMat(4,5)
         res(2,2,2,3) = afMat(2,5)
         res(3,2,2,3) = afMat(5,5)
         res(1,3,2,3) = afMat(6,5)
         res(2,3,2,3) = afMat(5,5)
         res(3,3,2,3) = afMat(3,5)

         res(1,1,3,3) = afMat(1,3)
         res(2,1,3,3) = afMat(4,3)
         res(3,1,3,3) = afMat(6,3)
         res(1,2,3,3) = afMat(4,3)
         res(2,2,3,3) = afMat(2,3)
         res(3,2,3,3) = afMat(5,3)
         res(1,3,3,3) = afMat(6,3)
         res(2,3,3,3) = afMat(5,3)
         res(3,3,3,3) = afMat(3,3)
      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE contract3_t2f_6x1 (res, t2f)
      ! contracts a 3x3 tensor: res(6) = t2f(3x3) [3rd dimension]
      !     t2f            Tensor 2nd order; Dimension (DimxDim)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         REAL(8), INTENT(OUT) :: res (6)
         REAL(8), INTENT(IN)  :: t2f (3,3)

         !### VAR ###!

         !### CODE ###!
         res(1) = t2f(1,1)
         res(2) = t2f(2,2)
         res(3) = t2f(3,3)
         res(4) = t2f(1,2)
         res(5) = t2f(2,3)
         res(6) = t2f(3,1)
      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE contract3_t4f_6x6 (res, t4f)
      ! contracts a 3x3x3x3 tensor: res(6x6) = t2f(3x3x3x3) [3rd dimension]
      !     t4f            Tensor 4th order; Dimension (DimxDimxDimxDim)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         REAL(8), INTENT(OUT) :: res (6,6)
         REAL(8), INTENT(IN)  :: t4f (3,3,3,3)

         !### VAR ###!

         !### CODE ###!
         res(1,1) = t4f(1,1,1,1)
         res(2,1) = t4f(2,2,1,1)
         res(3,1) = t4f(3,3,1,1)
         res(4,1) = t4f(1,2,1,1)
         res(5,1) = t4f(2,3,1,1)
         res(6,1) = t4f(3,1,1,1)

         res(1,2) = t4f(1,1,2,2)
         res(2,2) = t4f(2,2,2,2)
         res(3,2) = t4f(3,3,2,2)
         res(4,2) = t4f(1,2,2,2)
         res(5,2) = t4f(2,3,2,2)
         res(6,2) = t4f(3,1,2,2)

         res(1,3) = t4f(1,1,3,3)
         res(2,3) = t4f(2,2,3,3)
         res(3,3) = t4f(3,3,3,3)
         res(4,3) = t4f(1,2,3,3)
         res(5,3) = t4f(2,3,3,3)
         res(6,3) = t4f(3,1,3,3)

         res(1,4) = t4f(1,1,1,2)
         res(2,4) = t4f(2,2,1,2)
         res(3,4) = t4f(3,3,1,2)
         res(4,4) = t4f(1,2,1,2)
         res(5,4) = t4f(2,3,1,2)
         res(6,4) = t4f(3,1,1,2)

         res(1,5) = t4f(1,1,2,3)
         res(2,5) = t4f(2,2,2,3)
         res(3,5) = t4f(3,3,2,3)
         res(4,5) = t4f(1,2,2,3)
         res(5,5) = t4f(2,3,2,3)
         res(6,5) = t4f(3,1,2,3)

         res(1,6) = t4f(1,1,3,1)
         res(2,6) = t4f(2,2,3,1)
         res(3,6) = t4f(3,3,3,1)
         res(4,6) = t4f(1,2,3,1)
         res(5,6) = t4f(2,3,3,1)
         res(6,6) = t4f(3,1,3,1)
      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE in1_ord11 (res, t1f_A, t1f_B, iDm)
      ! returns the first inner product of A and B
      ! res = a_i * b_i
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res
         REAL(8), INTENT(IN)  :: t1f_A (iDm)
         REAL(8), INTENT(IN)  :: t1f_B (iDm)

         !### VAR ###!
         integer  :: ii

         !### CODE ###!
         res = 0.0d0
         do ii = 1,iDm
            res = res + t1f_A(ii) * t1f_B(ii)
         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE in1_ord12 (res, t1f_A, t2f_B, iDm)
      ! returns the first inner product of A and B
      ! res_j = a_i * B_ij
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res (iDm)
         REAL(8), INTENT(IN)  :: t1f_A (iDm)
         REAL(8), INTENT(IN)  :: t2f_B (iDm,iDm)

         !### VAR ###!
         integer  :: ii,j
         real(8)  :: fSum

         !### CODE ###!
         do j = 1,iDm

            fSum = 0.0d0
            do ii = 1,iDm
               fSum = fSum + t1f_A(ii) * t2f_B(ii,j)
            enddo
            res(j) = fSum

         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE in1_ord21 (res, t2f_A, t1f_B, iDm)
      ! returns the first inner product of A and B
      ! res_i = A_ij * b_j
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res (iDm)
         REAL(8), INTENT(IN)  :: t2f_A (iDm,iDm)
         REAL(8), INTENT(IN)  :: t1f_B (iDm)

         !### VAR ###!
         integer  :: i,jj
         real(8)  :: fSum

         !### CODE ###!
         do i = 1,iDm

            fSum = 0.0d0
            do jj = 1,iDm
               fSum = fSum + t2f_A(i,jj) * t1f_B(jj)
            enddo
            res(i) = fSum

         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE in1_ord22 (res, t2f_A, t2f_B, iDm)
      ! returns the first inner product of A and B
      ! res_ij = A_ik * B_kj
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res (iDm,iDm)
         REAL(8), INTENT(IN)  :: t2f_A (iDm,iDm)
         REAL(8), INTENT(IN)  :: t2f_B (iDm,iDm)

         !### VAR ###!
         integer  :: i,j,kk
         real(8)  :: fSum

         !### CODE ###!
         do j = 1,iDm
            do i = 1,iDm

               fSum = 0.0d0
               do kk = 1,iDm
                  fSum = fSum + t2f_A(i,kk) * t2f_B(kk,j)
               enddo
               res(i,j) = fSum

            enddo
         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE in1_ord222 (res, t2f_A, t2f_B, t2f_C, iDm)
      ! returns the first inner product of A and B and C
      ! res_ij = A_ik * B_kl * C_lj
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res (iDm,iDm)
         REAL(8), INTENT(IN)  :: t2f_A (iDm,iDm)
         REAL(8), INTENT(IN)  :: t2f_B (iDm,iDm)
         REAL(8), INTENT(IN)  :: t2f_C (iDm,iDm)

         !### VAR ###!
         integer  :: i,j,kk,ll
         real(8)  :: fSum

         !### CODE ###!
         do j = 1,iDm
            do i = 1,iDm

               fSum = 0.0d0
               do ll = 1,iDm
                  do kk = 1,iDm
                     fSum = fSum + t2f_A(i,kk) * t2f_B(kk,ll) *
     *                  t2f_C(ll,j)
                  enddo
               enddo
               res(i,j) = fSum

            enddo
         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE in2_ord22 (res, t2f_A, t2f_B, iDm)
      ! returns the second inner product of A and B
      ! res = A_ij * B_ij
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res
         REAL(8), INTENT(IN)  :: t2f_A (iDm,iDm)
         REAL(8), INTENT(IN)  :: t2f_B (iDm,iDm)

         !### VAR ###!
         integer  :: ii,jj

         !### CODE ###!
         res = 0.0d0
         do jj = 1,iDm
            do ii = 1,iDm
               res = res + t2f_A(ii,jj) * t2f_B(ii,jj)
            enddo
         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE in2_ord24 (res, t2f_A, t4f_B, iDm)
      ! returns the second inner product of A and B
      ! res_ij = A_kl * B_klij
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res (iDm,iDm)
         REAL(8), INTENT(IN)  :: t2f_A (iDm,iDm)
         REAL(8), INTENT(IN)  :: t4f_B (iDm,iDm,iDm,iDm)

         !### VAR ###!
         integer  :: i,j,kk,ll
         real(8)  :: fSum

         !### CODE ###!
         do j = 1,iDm
            do i = 1,iDm

               fSum = 0.0d0
               do ll = 1,iDm
                  do kk = 1,iDm
                     fSum = fSum + t2f_A(kk,ll) * t4f_B(kk,ll,i,j)
                  enddo
               enddo
               res(i,j) = fSum

            enddo
         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE in2_ord42 (res, t4f_A, t2f_B, iDm)
      ! returns the second inner product of A and B
      ! res_ij = A_ijkl * B_kl
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res (iDm,iDm)
         REAL(8), INTENT(IN)  :: t4f_A (iDm,iDm,iDm,iDm)
         REAL(8), INTENT(IN)  :: t2f_B (iDm,iDm)

         !### VAR ###!
         integer  :: i,j,kk,ll
         real(8)  :: fSum

         !### CODE ###!
         do j = 1,iDm
            do i = 1,iDm

               fSum = 0.0d0
               do ll = 1,iDm
                  do kk = 1,iDm
                     fSum = fSum + t4f_A(i,j,kk,ll) * t2f_B(kk,ll)
                  enddo
               enddo
               res(i,j) = fSum

            enddo
         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE in2_ord44 (res, t4f_A, t4f_B, iDm)
      ! returns the second inner product of A and B
      ! res_ijkl = A_ijmn * B_mnkl
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res (iDm,iDm,iDm,iDm)
         REAL(8), INTENT(IN)  :: t4f_A (iDm,iDm,iDm,iDm)
         REAL(8), INTENT(IN)  :: t4f_B (iDm,iDm,iDm,iDm)

         !### VAR ###!
         integer  :: i,j,k,l,mm,nn
         real(8)  :: fSum

         !### CODE ###!
         do l = 1,iDm
            do k = 1,iDm
               do j = 1,iDm
                  do i = 1,iDm

                     fSum = 0.0d0
                     do nn = 1,iDm
                        do mm = 1,iDm
                           fSum = fSum +
     *                        t4f_A(i,j,mm,nn) * t4f_B(mm,nn,k,l)
                        enddo
                     enddo
                     res(i,j,k,l) = fSum

                  enddo
               enddo
            enddo
         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE in2_ord444 (res, t4f_A, t4f_B, t4f_C, iDm)
      ! returns the second inner product of A and B and C
      ! res_ijkl = A_ijmn * B_mnop * C_opkl
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res (iDm,iDm,iDm,iDm)
         REAL(8), INTENT(IN)  :: t4f_A (iDm,iDm,iDm,iDm)
         REAL(8), INTENT(IN)  :: t4f_B (iDm,iDm,iDm,iDm)
         REAL(8), INTENT(IN)  :: t4f_C (iDm,iDm,iDm,iDm)

         !### VAR ###!
         integer  :: i,j,k,l,mm,nn,oo,pp
         real(8)  :: fSum

         !### CODE ###!
         do l = 1,iDm
            do k = 1,iDm
               do j = 1,iDm
                  do i = 1,iDm

                     fSum = 0.0d0
                     do pp = 1,iDm
                        do oo = 1,iDm
                           do nn = 1,iDm
                              do mm = 1,iDm
                                 fSum = fSum +
     *                              t4f_A(i,j,mm,nn) *
     *                              t4f_B(mm,nn,oo,pp) *
     *                              t4f_C(oo,pp,k,l)
                              enddo
                           enddo
                        enddo
                     enddo
                     res(i,j,k,l) = fSum

                  enddo
               enddo
            enddo
         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE dyad_ord11 (res, t1f_A, t1f_B, iDm)
      ! returns the outer/dyadic product of A and B
      ! res_ij = a_i * b_j
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res (iDm,iDm)
         REAL(8), INTENT(IN)  :: t1f_A (iDm)
         REAL(8), INTENT(IN)  :: t1f_B (iDm)

         !### VAR ###!
         integer  :: i,j

         !### CODE ###!
         do j = 1,iDm
            do i = 1,iDm
               res(i,j) = t1f_A(i) * t1f_B(j)
            enddo
         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE dyad_ord22 (res, t2f_A, t2f_B, iDm)
      ! returns the outer/dyadic product of A and B
      ! res_ijkl = A_ij * B_kl
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         INTEGER, INTENT(IN)  :: iDm
         REAL(8), INTENT(OUT) :: res (iDm,iDm,iDm,iDm)
         REAL(8), INTENT(IN)  :: t2f_A (iDm,iDm)
         REAL(8), INTENT(IN)  :: t2f_B (iDm,iDm)

         !### VAR ###!
         integer  :: i,j,k,l

         !### CODE ###!
         do l = 1,iDm
            do k = 1,iDm
               do j = 1,iDm
                  do i = 1,iDm
                     res(i,j,k,l) = t2f_A(i,j) * t2f_B(k,l)
                  enddo
               enddo
            enddo
         enddo

      END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE inv_6x6_sym (res, afMat)
      ! returns the inversion of a 6x6 (sym) matrix by using the MKL
      ! subroutine dsytri(uplo,n,a,lda,ipiv,work,info)
      ! res = inv(A) [sym]
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         IMPLICIT NONE
         REAL(8), INTENT(OUT) :: res (6,6)
         REAL(8), INTENT(IN)  :: afMat (6,6)

         !### VAR ###!
         character(1), parameter :: uplo = 'U'
         integer                 :: ipiv(6)
         integer                 :: lwork
         real(8),allocatable     :: work(:)
         integer                 :: info

         !### CODE ###!
         res = afMat

         ! allocate the workspace
         lwork = -1
         allocate(work(1))
         call dsytrf(uplo,6,res,6,ipiv,work,lwork,info)
         lwork = nint(work(1))
         deallocate(work)

         ! call Bunch-Kaufman factorization
         allocate(work(lwork))
         call dsytrf(uplo,6,res,6,ipiv,work,lwork,info)
         deallocate(work)

         if (info == 0) then
            ! call inversion of a symmetric matrix
            allocate(work(2*6))
            call dsytri(uplo,6,res,6,ipiv,work,info)
            deallocate(work)

            if (info /= 0) then
               res = real(info,8)
            else
               ! mirror sym U to L
               res(2,1) = res(1,2)
               res(3,1) = res(1,3)
               res(4,1) = res(1,4)
               res(5,1) = res(1,5)
               res(6,1) = res(1,6)
               res(3,2) = res(2,3)
               res(4,2) = res(2,4)
               res(5,2) = res(2,5)
               res(6,2) = res(2,6)
               res(4,3) = res(3,4)
               res(5,3) = res(3,5)
               res(6,3) = res(3,6)
               res(5,4) = res(4,5)
               res(6,4) = res(4,6)
               res(6,5) = res(5,6)
            endif
         else
            res = real(info,8)
         endif

      END SUBROUTINE

!######################################################################!
      END MODULE comMath
!######################################################################!


    !use crop2mlModules
        IF (choosePhyllUse .EQ. 'Default') THEN
            IF (leafNumber < ldecr) THEN
                phyllochron = fixPhyll * pdecr
            ELSE IF ((leafNumber >= ldecr) .AND. (leafNumber < lincr)) THEN
                phyllochron = fixPhyll
            ELSE
                phyllochron = fixPhyll * pincr
            END IF
        END IF
        IF (choosePhyllUse .EQ. 'PTQ') THEN
            gai = MAX(pastMaxAI,gai)
            pastMaxAI = gai
            IF (gai > 0.0) THEN
                phyllochron = phylPTQ1 * ((gai * kl) / (1 - EXP(-kl * gai))) / (ptq + aPTQ)
            ELSE
                phyllochron = phylPTQ1
            END IF
        END IF
        IF (choosePhyllUse == 'Test') THEN

            IF (leafNumber < ldecr) THEN
                phyllochron = p * pdecr
            ELSE IF ((leafNumber >= ldecr) .AND. (leafNumber < lincr)) THEN
                phyllochron = p
            ELSE
                phyllochron = p * pincr
            END IF
        END IF


module HyPerLayer
implicit none

real, parameter :: FP_INT_CORR = 0.5

type, BIND(C) :: PVLayerLoc
   real nx, ny
   real nxGlobal, nyGlobal ! total number of neurons in (x,y) across all hypercolumns
   real kx0, ky0  ! origin of the layer in index space
   real dx, dy;   ! maybe not needed but can use for padding anyway
end type PVLayerLoc

contains

!$FTT vectorize
real function featureIndex(k, nx, ny, nf) result(kf) BIND(C, name="featureIndex")
    integer, value, intent(in) :: k
    real,    value, intent(in) :: nx, ny, nf

    kf = MOD(REAL(k), nf)

end function featureIndex

!$FTT vectorize
real function kxPos(k, nx, ny, nf) result(kx) BIND(C, name="kxPos")
    integer, value, intent(in) :: k
    real,    value, intent(in) :: nx, ny, nf

   kx = FLOOR( MOD( REAL(FLOOR(REAL(k) / nf)), nx ) )

end function kxPos

!$FTT vectorize
real function kyPos(k, nx, ny, nf) result(ky) BIND(C, name="kyPos")
    integer, value, intent(in) :: k
    real,    value,  intent(in) :: nx, ny, nf

   ky = FLOOR( (REAL(k) / (nx*nf)) );

end function kyPos

!$FTT vectorize
integer function kIndexLocal(kx, ky, kf, nx, ny, nf) result(k) BIND(C, name="kIndexLocal")
    real, value, intent(in) :: kx, ky, kf, nx, ny, nf

    k = kf + (kx + ky * nx) * nf

end function kIndex

!$FTT vectorize
integer function kIndex(kx, ky, kf, nx, ny, nf) result(k) BIND(C, name="kIndex")
    real, value, intent(in) :: kx, ky, kf, nx, ny, nf
    integer :: ikx, iky, ikf, inx, iny, inf

    ikx = kf; iky = ky; ikf = kf
    inx = nx; iny = ny; inf = nf

    k = ikf + (ikx + iky * inx) * inf

end function kIndex

integer function gkIndex(loc) result(k) BIND(C)
    type(PVLayerLoc) :: loc

    k = loc%nx

end function gkIndex

!$FTT vectorize
integer function globalIndexFromLocal(kl, loc, nf) result(k) BIND(C, name="globalIndexFromLocal")
    integer, value, intent(in) :: kl
    real,    value, intent(in) :: nf
    type(PVLayerLoc), intent(in) :: loc

    real :: kxg, kyg, kf

   kxg = loc%kx0 + kxPos(kl, loc%nx, loc%ny, nf)
   kyg = loc%ky0 + kyPos(kl, loc%nx, loc%ny, nf)
   kf = featureIndex(kl, loc%nx, loc%ny, nf)

   k = kIndex(kxg, kyg, kf, loc%nxGlobal, loc%nyGlobal, nf)

end function globalIndexFromLocal

!
! OLD functions
!

!$FTT vectorize
elemental real function xPos(idx, nx, x0, dx, numFeatures) result(x)
    integer, intent(in) :: idx, nx, numFeatures
    real,    intent(in) :: dx, x0

    x = x0 + dx*(0.5 + MOD((idx/numFeatures),nx));

end function xPos

!$FTT vectorize
elemental real function yPos(idx, nx, y0, dy, numFeatures) result(y)
    integer, intent(in) :: idx, nx, numFeatures
    real,    intent(in) :: dy, y0
    integer :: ky

    ky = idx / INT(REAL(nx) * REAL(numFeatures) + FP_INT_CORR)
    y  = y0 + dy*(0.5 + ky)

end function yPos

!$FTT vectorize
elemental integer function globalIndex(kf, x, y, x0, y0, dx, dy, nx, numFeatures) result(idx)
    real, intent(in)    :: x, y, x0, y0, dx, dy
    integer, intent(in) :: kf, nx, numFeatures
    integer :: kx, ky

    kx = INT( (x - x0)/dx - 0.5 + FP_INT_CORR )
    ky = INT( (y - y0)/dy - 0.5 + FP_INT_CORR )

    idx = (kx + nx*ky)*numFeatures + kf

end function globalIndex

end module HyperLayer