SUBROUTINE stiff10(km,coord,ym,pr)
!
!    exact stiffness matrix of a 10-node triangle
!    with straight sides in plane strain
!
 IMPLICIT NONE
 INTEGER::i,j
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(10,2),ym,pr
 REAL(iwp),INTENT(OUT)::km(20,20)
 REAL(iwp)::x1,x4,x7,y1,y4,y7,cf
 REAL(iwp)::d0=0._iwp,d1=1._iwp,d2=2._iwp,d3=3._iwp,d7=7._iwp,d8=8._iwp,  &
   d10=10._iwp,d16=16._iwp,d17=17._iwp,d20=20._iwp,d27=27._iwp,           &
   d32=32._iwp,d40=40._iwp,d51=51._iwp,d57=57._iwp,d64=64._iwp,           &
   d80=80._iwp,d81=81._iwp,d160=160._iwp,d189=189._iwp,d320=320._iwp
 x1=coord(1,1)
 y1=coord(1,2)
 x4=coord(4,1)
 y4=coord(4,2)
 x7=coord(7,1)
 y7=coord(7,2)
 cf=ym/(-d1+d2*pr)/(d1+pr)/(x1*y4-x1*y7+x4*y7-y1*x4+y1*x7-y4*x7)
!--------------------------------------------------------------------------
  km(1,1)=-d17/d80*(-2*y4**2+4*y4*y7-2*y7**2+2*pr*y4**2-4*pr*y4*y7+       &
    2*pr*y7**2-x4**2+2*x4**2*pr+2*x4*x7-4*x4*x7*pr-x7**2+2*x7**2*pr)*cf
  km(1,2)=-d17/d80*(y4-y7)*(x4-x7)*cf
  km(1,3)=d3/d160*(-34*x4*x7*pr-2*pr*y4**2-34*pr*y4*y7+2*y4**2+34*y4*y7-  &
    36*y7**2+36*pr*y7**2+x4**2+17*x4*x7-18*x7**2-2*x4**2*pr+36*x7**2*pr+  &
    38*pr*y4*y1-38*pr*y7*y1+38*x4*x1*pr-38*x7*x1*pr-38*y4*y1+38*y7*y1-    &
    19*x4*x1+19*x7*x1)*cf
  km(1,4)=d3/d160*(-18*x4*y7-x4*y4+19*y1*x4-19*y1*x7+y4*x7+18*y7*x7-      &
    38*pr*y4*x7+38*pr*x4*y7+38*pr*y4*x1-38*pr*y7*x1-38*x4*y1*pr+          &
    38*x7*y1*pr)*cf
  km(1,5)=-d3/d160*(-20*x4*x7*pr+2*pr*y4**2-20*pr*y4*y7-2*y4**2+          &
    20*y4*y7-18*y7**2+18*pr*y7**2-x4**2+10*x4*x7-9*x7**2+2*x4**2*pr+      &
    18*x7**2*pr+16*pr*y4*y1-16*pr*y7*y1+16*x4*x1*pr-16*x7*x1*pr-          &
    16*y4*y1+16*y7*y1-8*x4*x1+8*x7*x1)*cf
  km(1,6)=-d3/d160*(-9*x4*y7+x4*y4+8*y1*x4-8*y1*x7-y4*x7+9*y7*x7-         &
    16*pr*y4*x7+16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+          &
    16*x7*y1*pr)*cf
  km(1,7)=d7/d160*(2*y4*y7-2*y4*y1-2*y7**2+2*y7*y1-2*pr*y4*y7+            &
    2*pr*y4*y1+2*pr*y7**2-2*pr*y7*y1-x4*x1+2*x4*x1*pr+x4*x7-2*x4*x7*pr+   &
    x7*x1-2*x7*x1*pr-x7**2+2*x7**2*pr)*cf
  km(1,8)=d7/d160*(2*pr*y4*x1-2*pr*y4*x7-2*pr*y7*x1-x4*y7+2*pr*x4*y7+     &
    y1*x4-2*x4*y1*pr+y7*x7-y1*x7+2*x7*y1*pr)*cf
  km(1,9)=d3/d160*(-2*y4**2+4*y4*y7-2*y7**2+2*pr*y4**2-4*pr*y4*y7+        &
    2*pr*y7**2-x4**2+2*x4**2*pr+2*x4*x7-4*x4*x7*pr-x7**2+2*x7**2*pr)*cf
  km(1,10)=d3/d160*(-y4*x7-x4*y7+x4*y4+y7*x7)*cf
  km(1,11)=km(1,9)
  km(1,12)=km(1,10)
  km(1,13)=-d7/d160*(2*y4**2-2*y4*y7+x4**2-x4*x7-2*x4**2*pr+2*x4*x1*pr+   &
    2*x4*x7*pr+2*pr*y4*y1-2*pr*y7*y1-x4*x1-2*x7*x1*pr-2*y4*y1+2*y7*y1+    &
    x7*x1-2*pr*y4**2+2*pr*y4*y7)*cf
  km(1,14)=-d7/d160*(-x4*y4+y1*x4-y1*x7+y4*x7+2*pr*y4*x1-2*pr*y7*x1-      &
    2*x4*y1*pr+2*x7*y1*pr+2*pr*x4*y7-2*pr*y4*x7)*cf
  km(1,15)=d3/d160*(20*x4*x7*pr-18*pr*y4**2+20*pr*y4*y7+18*y4**2-         &
    20*y4*y7+2*y7**2-2*pr*y7**2+9*x4**2-10*x4*x7+x7**2-18*x4**2*pr-       &
    2*x7**2*pr+16*pr*y4*y1-16*pr*y7*y1+16*x4*x1*pr-16*x7*x1*pr-16*y4*y1+  &
    16*y7*y1-8*x4*x1+8*x7*x1)*cf
  km(1,16)=d3/d160*(x4*y7-9*x4*y4+8*y1*x4-8*y1*x7+9*y4*x7-y7*x7-          &
    16*pr*y4*x7+16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+          &
    16*x7*y1*pr)*cf
  km(1,17)=-d3/d160*(34*x4*x7*pr-36*pr*y4**2+34*pr*y4*y7+36*y4**2-        &
    34*y4*y7-2*y7**2+2*pr*y7**2+18*x4**2-17*x4*x7-x7**2-36*x4**2*pr+      &
    2*x7**2*pr+38*pr*y4*y1-38*pr*y7*y1+38*x4*x1*pr-38*x7*x1*pr-38*y4*y1+  &
    38*y7*y1-19*x4*x1+19*x7*x1)*cf
  km(1,18)=-d3/d160*(-18*x4*y4+19*y1*x4-19*y1*x7+18*y4*x7+38*pr*y4*x1-    &
    38*pr*y7*x1-38*x4*y1*pr+38*x7*y1*pr+38*pr*x4*y7-38*pr*y4*x7-x4*y7+    &
    y7*x7)*cf
  km(1,19)=d0
  km(1,20)=d0
!--------------------------------------------------------------------------
  km(2,2)=-d17/d80*(-2*x4**2+4*x4*x7-2*x7**2+2*x4**2*pr-4*x4*x7*pr+       &
    2*x7**2*pr-y4**2+2*pr*y4**2+2*y4*y7-4*pr*y4*y7-y7**2+2*pr*y7**2)*cf
  km(2,3)=-d3/d160*(-x4*y7-19*x1*y4+x4*y4+19*x1*y7+18*y4*x7-18*y7*x7-     &
    38*pr*y4*x7+38*pr*x4*y7+38*pr*y4*x1-38*pr*y7*x1-38*x4*y1*pr+          &
    38*x7*y1*pr)*cf
  km(2,4)=d3/d160*(-34*x4*x7*pr-2*pr*y4**2-34*pr*y4*y7+y4**2+17*y4*y7-    &
    18*y7**2+36*pr*y7**2+2*x4**2+34*x4*x7-36*x7**2-2*x4**2*pr+            &
    36*x7**2*pr+38*pr*y4*y1-38*pr*y7*y1+38*x4*x1*pr-38*x7*x1*pr-          &
    19*y4*y1+19*y7*y1-38*x4*x1+38*x7*x1)*cf
  km(2,5)=d3/d160*(x4*y7-8*x1*y4-x4*y4+8*x1*y7+9*y4*x7-9*y7*x7-           &
    16*pr*y4*x7+16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+          &
    16*x7*y1*pr)*cf
  km(2,6)=-d3/d160*(-20*x4*x7*pr+2*pr*y4**2-20*pr*y4*y7-y4**2+10*y4*y7-   &
    9*y7**2+18*pr*y7**2-2*x4**2+20*x4*x7-18*x7**2+2*x4**2*pr+             &
    18*x7**2*pr+16*pr*y4*y1-16*pr*y7*y1+16*x4*x1*pr-16*x7*x1*pr-8*y4*y1+  &
    8*y7*y1-16*x4*x1+16*x7*x1)*cf
  km(2,7)=-d7/d160*(2*pr*x4*y7-2*x4*y1*pr+2*x7*y1*pr-x1*y4+2*pr*y4*x1+    &
    y4*x7-2*pr*y4*x7+x1*y7-2*pr*y7*x1-y7*x7)*cf
  km(2,8)=d7/d160*(-2*x4*x1+2*x4*x7+2*x7*x1-2*x7**2+2*x4*x1*pr-           &
    2*x4*x7*pr-2*x7*x1*pr+2*x7**2*pr+y4*y7-2*pr*y4*y7-y4*y1+2*pr*y4*y1-   &
    y7**2+2*pr*y7**2+y7*y1-2*pr*y7*y1)*cf
  km(2,9)=km(1,10)
  km(2,10)=d3/d160*(-2*x4**2+4*x4*x7-2*x7**2+2*x4**2*pr-4*x4*x7*pr+       &
    2*x7**2*pr-y4**2+2*pr*y4**2+2*y4*y7-4*pr*y4*y7-y7**2+2*pr*y7**2)*cf
  km(2,11)=km(1,10)
  km(2,12)=km(2,10)
  km(2,13)=d7/d160*(-x4*y7-x1*y4+x4*y4+x1*y7+2*pr*x4*y7+2*pr*y4*x1-       &
    2*pr*y7*x1-2*pr*y4*x7+2*x7*y1*pr-2*x4*y1*pr)*cf
  km(2,14)=-d7/d160*(y7*y1-2*pr*y4**2+2*x7*x1+y4**2-y4*y7+2*x4**2-        &
    2*x4*x7-2*x4**2*pr+2*pr*y4*y1+2*x4*x7*pr+2*x4*x1*pr-2*x7*x1*pr-       &
    y4*y1+2*pr*y4*y7-2*x4*x1-2*pr*y7*y1)*cf
  km(2,15)=-d3/d160*(-9*x4*y7-8*x1*y4+9*x4*y4+8*x1*y7-y4*x7+y7*x7-        &
    16*pr*y4*x7+16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+          &
    16*x7*y1*pr)*cf
  km(2,16)=d3/d160*(20*x4*x7*pr-18*pr*y4**2+20*pr*y4*y7+9*y4**2-          &
    10*y4*y7+y7**2-2*pr*y7**2+18*x4**2-20*x4*x7+2*x7**2-18*x4**2*pr-      &
    2*x7**2*pr+16*pr*y4*y1-16*pr*y7*y1+16*x4*x1*pr-16*x7*x1*pr-8*y4*y1+   &
    8*y7*y1-16*x4*x1+16*x7*x1)*cf
  km(2,17)=d3/d160*(y4*x7-18*x4*y7+18*x4*y4-y7*x7-19*x1*y4+19*x1*y7+      &
    38*pr*x4*y7+38*pr*y4*x1-38*pr*y7*x1-38*pr*y4*x7+38*x7*y1*pr-          &
    38*x4*y1*pr)*cf
  km(2,18)=-d3/d160*(34*x4*x7*pr-36*pr*y4**2+34*pr*y4*y7+18*y4**2-        &
    17*y4*y7-y7**2+2*pr*y7**2+36*x4**2-34*x4*x7-2*x7**2-36*x4**2*pr+      &
    2*x7**2*pr+38*pr*y4*y1-38*pr*y7*y1+38*x4*x1*pr-38*x7*x1*pr-19*y4*y1+  &
    19*y7*y1-38*x4*x1+38*x7*x1)*cf
  km(2,19)=0
  km(2,20)=0
!--------------------------------------------------------------------------
  km(3,3)=-d27/d32*(-2*x4*x7*pr+2*pr*y4**2-2*pr*y4*y7+2*x1**2*pr+         &
    2*pr*y1**2-x1**2-2*y4**2+2*y4*y7-2*y7**2+2*pr*y7**2-x4**2+x4*x7-      &
    x7**2+2*x4**2*pr+2*x7**2*pr-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-         &
    2*x7*x1*pr+2*y4*y1+2*y7*y1+x4*x1+x7*x1-2*y1**2)*cf
  km(3,4)=-d27/d64*(-x4*y7-x1*y4+2*x4*y4-x1*y7-y1*x4-y1*x7-y4*x7+         &
    2*y7*x7+2*x1*y1)*cf
  km(3,5)=d27/d160*(-8*x4*x7*pr+2*pr*y4**2-8*pr*y4*y7+2*x1**2*pr+         &
    2*pr*y1**2-x1**2-2*y4**2+8*y4*y7-8*y7**2+8*pr*y7**2-x4**2+4*x4*x7-    &
    4*x7**2+2*x4**2*pr+8*x7**2*pr+4*pr*y4*y1-8*pr*y7*y1+4*x4*x1*pr-       &
    8*x7*x1*pr-4*y4*y1+8*y7*y1-2*x4*x1+4*x7*x1-2*y1**2)*cf
  km(3,6)=d27/d320*(-7*x4*y7-x1*y4+2*x4*y4-x1*y7+5*y1*x4-7*y1*x7-y4*x7+   &
    8*y7*x7-12*pr*y4*x7+12*pr*x4*y7+12*pr*y4*x1-12*pr*y7*x1-12*x4*y1*pr+  &
    12*x7*y1*pr+2*x1*y1)*cf
  km(3,7)=-d3/d160*(-16*x4*x7*pr-16*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-       &
    x1**2+16*y4*y7-18*y7**2+18*pr*y7**2+8*x4*x7-9*x7**2+18*x7**2*pr+      &
    16*pr*y4*y1-20*pr*y7*y1+16*x4*x1*pr-20*x7*x1*pr-16*y4*y1+20*y7*y1-    &
    8*x4*x1+10*x7*x1-2*y1**2)*cf
  km(3,8)=-d3/d160*(-8*x4*y7-x1*y7+8*y1*x4-9*y1*x7+9*y7*x7-16*pr*y4*x7+   &
    16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+16*x7*y1*pr+x1*y1)*cf
  km(3,9)=d27/d160*(2*y4**2-2*y4*y7+x4**2-x4*x7-2*x4**2*pr+2*x4*x1*pr+    &
    2*x4*x7*pr+2*pr*y4*y1-2*pr*y7*y1-x4*x1-2*x7*x1*pr-2*y4*y1+2*y7*y1+    &
    x7*x1-2*pr*y4**2+2*pr*y4*y7)*cf
  km(3,10)=d27/d320*(x4*y7+x1*y4-2*x4*y4-x1*y7+y1*x4-y1*x7+y4*x7)*cf
  km(3,11)=km(3,9)
  km(3,12)=km(3,10)
  km(3,13)=d3/d160*(2*pr*y4**2+2*x1**2*pr+2*pr*y1**2-x1**2-2*y4**2-       &
    x4**2+2*x4**2*pr-4*pr*y4*y1-4*x4*x1*pr+4*y4*y1+2*x4*x1-2*y1**2)*cf
  km(3,14)=d3/d160*(-x1*y4+x4*y4-y1*x4+x1*y1)*cf
  km(3,15)=-d27/d160*(2*x4*x7*pr+2*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-x1**2-  &
    2*y4*y7-x4*x7-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-2*x7*x1*pr+2*y4*y1+    &
    2*y7*y1+x4*x1+x7*x1-2*y1**2)*cf
  km(3,16)=-d27/d320*(x4*y7-x1*y4-x1*y7-y1*x4-y1*x7+y4*x7+2*x1*y1)*cf
  km(3,17)=d27/d32*(2*x4*x7*pr+2*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-x1**2-    &
    2*y4*y7-x4*x7-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-2*x7*x1*pr+2*y4*y1+    &
    2*y7*y1+x4*x1+x7*x1-2*y1**2)*cf
  km(3,18)=d27/d64*(x4*y7-x1*y4-x1*y7-y1*x4-y1*x7+y4*x7+2*x1*y1)*cf
  km(3,19)=-d81/d80*(2*y4**2-2*y4*y7+x4**2-x4*x7-2*x4**2*pr+2*x4*x1*pr+   &
    2*x4*x7*pr+2*pr*y4*y1-2*pr*y7*y1-x4*x1-2*x7*x1*pr-2*y4*y1+2*y7*y1+    &
    x7*x1-2*pr*y4**2+2*pr*y4*y7)*cf
  km(3,20)=-d81/d160*(x4*y7+x1*y4-2*x4*y4-x1*y7+y1*x4-y1*x7+y4*x7)*cf
!--------------------------------------------------------------------------
  km(4,4)=-d27/d32*(-2*x4*x7*pr+2*pr*y4**2-2*pr*y4*y7+2*x1**2*pr+         &
    2*pr*y1**2-2*x1**2-y4**2+y4*y7-y7**2+2*pr*y7**2-2*x4**2+2*x4*x7-      &
    2*x7**2+2*x4**2*pr+2*x7**2*pr-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-       &
    2*x7*x1*pr+y4*y1+y7*y1+2*x4*x1+2*x7*x1-y1**2)*cf
  km(4,5)=-d27/d320*(x4*y7-5*x1*y4-2*x4*y4+7*x1*y7+y1*x4+y1*x7+7*y4*x7-   &
    8*y7*x7-12*pr*y4*x7+12*pr*x4*y7+12*pr*y4*x1-12*pr*y7*x1-12*x4*y1*pr+  &
    12*x7*y1*pr-2*x1*y1)*cf
  km(4,6)=d27/d160*(-8*x4*x7*pr+2*pr*y4**2-8*pr*y4*y7+2*x1**2*pr+         &
    2*pr*y1**2-2*x1**2-y4**2+4*y4*y7-4*y7**2+8*pr*y7**2-2*x4**2+8*x4*x7-  &
    8*x7**2+2*x4**2*pr+8*x7**2*pr+4*pr*y4*y1-8*pr*y7*y1+4*x4*x1*pr-       &
    8*x7*x1*pr-2*y4*y1+4*y7*y1-4*x4*x1+8*x7*x1-y1**2)*cf
  km(4,7)=d3/d160*(-8*x1*y4+9*x1*y7+y1*x7+8*y4*x7-9*y7*x7-16*pr*y4*x7+    &
    16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+16*x7*y1*pr-x1*y1)*cf
  km(4,8)=-d3/d160*(-16*x4*x7*pr-16*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-       &
    2*x1**2+8*y4*y7-9*y7**2+18*pr*y7**2+16*x4*x7-18*x7**2+18*x7**2*pr+    &
    16*pr*y4*y1-20*pr*y7*y1+16*x4*x1*pr-20*x7*x1*pr-8*y4*y1+10*y7*y1-     &
    16*x4*x1+20*x7*x1-y1**2)*cf
  km(4,9)=km(3,10)
  km(4,10)=d27/d160*(y7*y1-2*pr*y4**2+2*x7*x1+y4**2-y4*y7+2*x4**2-        &
    2*x4*x7-2*x4**2*pr+2*pr*y4*y1+2*x4*x7*pr+2*x4*x1*pr-2*x7*x1*pr-       &
    y4*y1+2*pr*y4*y7-2*x4*x1-2*pr*y7*y1)*cf
  km(4,11)=km(3,10)
  km(4,12)=km(4,10)
  km(4,13)=km(3,14)
  km(4,14)=d3/d160*(2*pr*y4**2+2*x1**2*pr+2*pr*y1**2-2*x1**2-y4**2-       &
    2*x4**2+2*x4**2*pr-4*pr*y4*y1-4*x4*x1*pr+2*y4*y1+4*x4*x1-y1**2)*cf
  km(4,15)=km(3,16)
  km(4,16)=-d27/d160*(2*x4*x7*pr+2*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-        &
    2*x1**2-y4*y7-2*x4*x7-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-2*x7*x1*pr+    &
    y4*y1+y7*y1+2*x4*x1+2*x7*x1-y1**2)*cf
  km(4,17)=km(3,18)
  km(4,18)=d27/d32*(2*x4*x7*pr+2*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-2*x1**2-  &
    y4*y7-2*x4*x7-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-2*x7*x1*pr+y4*y1+      &
    y7*y1+2*x4*x1+2*x7*x1-y1**2)*cf
  km(4,19)=km(3,20)
  km(4,20)=-d81/d80*(y7*y1-2*pr*y4**2+2*x7*x1+y4**2-y4*y7+2*x4**2-        &
    2*x4*x7-2*x4**2*pr+2*pr*y4*y1+2*x4*x7*pr+2*x4*x1*pr-2*x7*x1*pr-       &
    y4*y1+2*pr*y4*y7-2*x4*x1-2*pr*y7*y1)*cf
!--------------------------------------------------------------------------
  km(5,5)=km(3,3)
  km(5,6)=km(3,4)
  km(5,7)=-d3/d160*(38*x4*x7*pr+38*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-x1**2-  &
    38*y4*y7+36*y7**2-36*pr*y7**2-19*x4*x7+18*x7**2-36*x7**2*pr-          &
    38*pr*y4*y1+34*pr*y7*y1-38*x4*x1*pr+34*x7*x1*pr+38*y4*y1-34*y7*y1+    &
    19*x4*x1-17*x7*x1-2*y1**2)*cf
  km(5,8)=d3/d160*(-19*x4*y7+x1*y7+19*y1*x4-18*y1*x7+18*y7*x7-            &
    38*pr*y4*x7+38*pr*x4*y7+38*pr*y4*x1-38*pr*y7*x1-38*x4*y1*pr+          &
    38*x7*y1*pr-x1*y1)*cf
  km(5,9)=-d27/d32*(2*y4**2-2*y4*y7+x4**2-x4*x7-2*x4**2*pr+2*x4*x1*pr+    &
    2*x4*x7*pr+2*pr*y4*y1-2*pr*y7*y1-x4*x1-2*x7*x1*pr-2*y4*y1+2*y7*y1+    &
    x7*x1-2*pr*y4**2+2*pr*y4*y7)*cf
  km(5,10)=-d27/d64*(x4*y7+x1*y4-2*x4*y4-x1*y7+y1*x4-y1*x7+y4*x7)*cf
  km(5,11)=km(3,9)
  km(5,12)=km(3,10)
  km(5,13)=km(3,13)
  km(5,14)=km(3,14)
  km(5,15)=km(3,15)
  km(5,16)=km(3,16)
  km(5,17)=km(3,15)
  km(5,18)=km(3,16)
  km(5,19)=d81/d80*(2*x4*x7*pr+2*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-x1**2-    &
    2*y4*y7-x4*x7-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-2*x7*x1*pr+2*y4*y1+    &
    2*y7*y1+x4*x1+x7*x1-2*y1**2)*cf
  km(5,20)=d81/d160*(x4*y7-x1*y4-x1*y7-y1*x4-y1*x7+y4*x7+2*x1*y1)*cf
!--------------------------------------------------------------------------
  km(6,6)=km(4,4)
  km(6,7)=-d3/d160*(-19*x1*y4+18*x1*y7-y1*x7+19*y4*x7-18*y7*x7-           &
    38*pr*y4*x7+38*pr*x4*y7+38*pr*y4*x1-38*pr*y7*x1-38*x4*y1*pr+          &
    38*x7*y1*pr+x1*y1)*cf
  km(6,8)=-d3/d160*(38*x4*x7*pr+38*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-        &
    2*x1**2-19*y4*y7+18*y7**2-36*pr*y7**2-38*x4*x7+36*x7**2-36*x7**2*pr-  &
    38*pr*y4*y1+34*pr*y7*y1-38*x4*x1*pr+34*x7*x1*pr+19*y4*y1-17*y7*y1+    &
    38*x4*x1-34*x7*x1-y1**2)*cf
  km(6,9)=km(5,10)
  km(6,10)=-d27/d32*(y7*y1-2*pr*y4**2+2*x7*x1+y4**2-y4*y7+2*x4**2-        &
    2*x4*x7-2*x4**2*pr+2*pr*y4*y1+2*x4*x7*pr+2*x4*x1*pr-2*x7*x1*pr-       &
    y4*y1+2*pr*y4*y7-2*x4*x1-2*pr*y7*y1)*cf
  km(6,11)=km(3,10)
  km(6,12)=km(4,10)
  km(6,13)=km(3,14)
  km(6,14)=km(4,14)
  km(6,15)=km(3,16)
  km(6,16)=km(4,16)
  km(6,17)=km(3,16)
  km(6,18)=km(4,16)
  km(6,19)=km(5,20)
  km(6,20)=d81/d80*(2*x4*x7*pr+2*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-2*x1**2-  &
    y4*y7-2*x4*x7-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-2*x7*x1*pr+y4*y1+      &
    y7*y1+2*x4*x1+2*x7*x1-y1**2)*cf
!--------------------------------------------------------------------------
  km(7,7)=-d17/d80*(-2*y7**2+4*y7*y1-2*y1**2+2*pr*y7**2-4*pr*y7*y1+       &
    2*pr*y1**2-x1**2+2*x1**2*pr+2*x7*x1-4*x7*x1*pr-x7**2+2*x7**2*pr)*cf
  km(7,8)=-d17/d80*(-y7+y1)*(x1-x7)*cf
  km(7,9)=d3/d160*(38*x4*x7*pr+38*pr*y4*y7+36*x1**2*pr+36*pr*y1**2-       &
    18*x1**2-38*y4*y7+2*y7**2-2*pr*y7**2-19*x4*x7+x7**2-2*x7**2*pr-       &
    38*pr*y4*y1-34*pr*y7*y1-38*x4*x1*pr-34*x7*x1*pr+38*y4*y1+34*y7*y1+    &
    19*x4*x1+17*x7*x1-36*y1**2)*cf
  km(7,10)=d3/d160*(-19*x1*y4+x1*y7-18*y1*x7+19*y4*x7-y7*x7-38*pr*y4*x7+  &
    38*pr*x4*y7+38*pr*y4*x1-38*pr*y7*x1-38*x4*y1*pr+38*x7*y1*pr+          &
    18*x1*y1)*cf
  km(7,11)=-d3/d160*(16*x4*x7*pr+16*pr*y4*y7+18*x1**2*pr+18*pr*y1**2-     &
    9*x1**2-16*y4*y7-2*y7**2+2*pr*y7**2-8*x4*x7-x7**2+2*x7**2*pr-         &
    16*pr*y4*y1-20*pr*y7*y1-16*x4*x1*pr-20*x7*x1*pr+16*y4*y1+20*y7*y1+    &
    8*x4*x1+10*x7*x1-18*y1**2)*cf
  km(7,12)=-d3/d160*(-8*x1*y4-x1*y7-9*y1*x7+8*y4*x7+y7*x7-16*pr*y4*x7+    &
    16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+16*x7*y1*pr+          &
    9*x1*y1)*cf
  km(7,13)=d7/d160*(2*x4*x7*pr+2*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-x1**2-    &
    2*y4*y7-x4*x7-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-2*x7*x1*pr+2*y4*y1+    &
    2*y7*y1+x4*x1+x7*x1-2*y1**2)*cf
  km(7,14)=d7/d160*(y4*x7-2*pr*y4*x7+2*pr*x4*y7+2*pr*y4*x1-2*pr*y7*x1-    &
    2*x4*y1*pr+2*x7*y1*pr+x1*y1-y1*x7-x1*y4)*cf
  km(7,15)=d3/d160*(-2*y7**2+4*y7*y1-2*y1**2+2*pr*y7**2-4*pr*y7*y1+       &
    2*pr*y1**2-x1**2+2*x1**2*pr+2*x7*x1-4*x7*x1*pr-x7**2+2*x7**2*pr)*cf
  km(7,16)=d3/d160*(x1*y1-y1*x7-x1*y7+y7*x7)*cf
  km(7,17)=km(7,15)
  km(7,18)=km(7,16)
  km(7,19)=d0
  km(7,20)=d0
!--------------------------------------------------------------------------
  km(8,8)=-d17/d80*(-2*x1**2+4*x7*x1-2*x7**2+2*x1**2*pr-4*x7*x1*pr+       &
    2*x7**2*pr-y7**2+2*pr*y7**2+2*y7*y1-4*pr*y7*y1-y1**2+2*pr*y1**2)*cf
  km(8,9)=-d3/d160*(-19*x4*y7+18*x1*y7+19*y1*x4-y1*x7+y7*x7-38*pr*y4*x7+  &
    38*pr*x4*y7+38*pr*y4*x1-38*pr*y7*x1-38*x4*y1*pr+38*x7*y1*pr-          &
    18*x1*y1)*cf
  km(8,10)=d3/d160*(38*x4*x7*pr+38*pr*y4*y7+36*x1**2*pr+36*pr*y1**2-      &
    36*x1**2-19*y4*y7+y7**2-2*pr*y7**2-38*x4*x7+2*x7**2-2*x7**2*pr-       &
    38*pr*y4*y1-34*pr*y7*y1-38*x4*x1*pr-34*x7*x1*pr+19*y4*y1+17*y7*y1+    &
    38*x4*x1+34*x7*x1-18*y1**2)*cf
  km(8,11)=d3/d160*(-8*x4*y7+9*x1*y7+8*y1*x4+y1*x7-y7*x7-16*pr*y4*x7+     &
    16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+16*x7*y1*pr-          &
    9*x1*y1)*cf
  km(8,12)=-d3/d160*(16*x4*x7*pr+16*pr*y4*y7+18*x1**2*pr+18*pr*y1**2-     &
    18*x1**2-8*y4*y7-y7**2+2*pr*y7**2-16*x4*x7-2*x7**2+2*x7**2*pr-        &
    16*pr*y4*y1-20*pr*y7*y1-16*x4*x1*pr-20*x7*x1*pr+8*y4*y1+10*y7*y1+     &
    16*x4*x1+20*x7*x1-9*y1**2)*cf
  km(8,13)=-d7/d160*(2*pr*y4*x1-x4*y7+2*pr*x4*y7+2*x7*y1*pr-2*pr*y4*x7-   &
    2*x4*y1*pr-2*pr*y7*x1-x1*y1+x1*y7+y1*x4)*cf
  km(8,14)=d7/d160*(2*x4*x7*pr+2*pr*y4*y7+2*x1**2*pr+2*pr*y1**2-2*x1**2-  &
    y4*y7-2*x4*x7-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-2*x7*x1*pr+y4*y1+      &
    y7*y1+2*x4*x1+2*x7*x1-y1**2)*cf
  km(8,15)=km(7,16)
  km(8,16)=d3/d160*(-2*x1**2+4*x7*x1-2*x7**2+2*x1**2*pr-4*x7*x1*pr+       &
    2*x7**2*pr-y7**2+2*pr*y7**2+2*y7*y1-4*pr*y7*y1-y1**2+2*pr*y1**2)*cf
  km(8,17)=km(7,16)
  km(8,18)=km(8,16)
  km(8,19)=d0
  km(8,20)=d0
!--------------------------------------------------------------------------
  km(9,9)=km(3,3)
  km(9,10)=km(3,4)
  km(9,11)=d27/d160*(4*x4*x7*pr+2*pr*y4**2+4*pr*y4*y7+8*x1**2*pr+         &
    8*pr*y1**2-4*x1**2-2*y4**2-4*y4*y7-2*y7**2+2*pr*y7**2-x4**2-2*x4*x7-  &
    x7**2+2*x4**2*pr+2*x7**2*pr-8*pr*y4*y1-8*pr*y7*y1-8*x4*x1*pr-         &
    8*x7*x1*pr+8*y4*y1+8*y7*y1+4*x4*x1+4*x7*x1-8*y1**2)*cf
  km(9,12)=d27/d320*(-x4*y7-7*x1*y4+2*x4*y4-x1*y7-y1*x4-7*y1*x7+5*y4*x7+  &
    2*y7*x7-12*pr*y4*x7+12*pr*x4*y7+12*pr*y4*x1-12*pr*y7*x1-12*x4*y1*pr+  &
    12*x7*y1*pr+8*x1*y1)*cf
  km(9,13)=-d3/d160*(16*x4*x7*pr+2*pr*y4**2+16*pr*y4*y7+18*x1**2*pr+      &
    18*pr*y1**2-9*x1**2-2*y4**2-16*y4*y7-x4**2-8*x4*x7+2*x4**2*pr-        &
    20*pr*y4*y1-16*pr*y7*y1-20*x4*x1*pr-16*x7*x1*pr+20*y4*y1+16*y7*y1+    &
    10*x4*x1+8*x7*x1-18*y1**2)*cf
  km(9,14)=-d3/d160*(-9*x1*y4+x4*y4-y1*x4-8*y1*x7+8*y4*x7-16*pr*y4*x7+    &
    16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+16*x7*y1*pr+          &
    9*x1*y1)*cf
  km(9,15)=-d27/d160*(2*y4*y7-2*y4*y1-2*y7**2+2*y7*y1-2*pr*y4*y7+         &
    2*pr*y4*y1+2*pr*y7**2-2*pr*y7*y1-x4*x1+2*x4*x1*pr+x4*x7-2*x4*x7*pr+   &
    x7*x1-2*x7*x1*pr-x7**2+2*x7**2*pr)*cf
  km(9,16)=-d27/d320*(-x4*y7+x1*y4-x1*y7+y1*x4-y1*x7-y4*x7+2*y7*x7)*cf
  km(9,17)=km(9,15)
  km(9,18)=km(9,16)
  km(9,19)=d81/d80*(2*y4*y7-2*y4*y1-2*y7**2+2*y7*y1-2*pr*y4*y7+           &
    2*pr*y4*y1+2*pr*y7**2-2*pr*y7*y1-x4*x1+2*x4*x1*pr+x4*x7-2*x4*x7*pr+   &
    x7*x1-2*x7*x1*pr-x7**2+2*x7**2*pr)*cf
  km(9,20)=d81/d160*(-x4*y7+x1*y4-x1*y7+y1*x4-y1*x7-y4*x7+2*y7*x7)*cf
!--------------------------------------------------------------------------
  km(10,10)=km(4,4)
  km(10,11)=-d27/d320*(-5*x4*y7+x1*y4-2*x4*y4+7*x1*y7+7*y1*x4+y1*x7+      &
    y4*x7-2*y7*x7-12*pr*y4*x7+12*pr*x4*y7+12*pr*y4*x1-12*pr*y7*x1-        &
    12*x4*y1*pr+12*x7*y1*pr-8*x1*y1)*cf
  km(10,12)=d27/d160*(4*x4*x7*pr+2*pr*y4**2+4*pr*y4*y7+8*x1**2*pr+        &
    8*pr*y1**2-8*x1**2-y4**2-2*y4*y7-y7**2+2*pr*y7**2-2*x4**2-4*x4*x7-    &
    2*x7**2+2*x4**2*pr+2*x7**2*pr-8*pr*y4*y1-8*pr*y7*y1-8*x4*x1*pr-       &
    8*x7*x1*pr+4*y4*y1+4*y7*y1+8*x4*x1+8*x7*x1-4*y1**2)*cf
  km(10,13)=d3/d160*(-8*x4*y7+x1*y4-x4*y4+8*x1*y7+9*y1*x4-16*pr*y4*x7+    &
    16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+16*x7*y1*pr-          &
    9*x1*y1)*cf
  km(10,14)=-d3/d160*(16*x4*x7*pr+2*pr*y4**2+16*pr*y4*y7+18*x1**2*pr+     &
    18*pr*y1**2-18*x1**2-y4**2-8*y4*y7-2*x4**2-16*x4*x7+2*x4**2*pr-       &
    20*pr*y4*y1-16*pr*y7*y1-20*x4*x1*pr-16*x7*x1*pr+10*y4*y1+8*y7*y1+     &
    20*x4*x1+16*x7*x1-9*y1**2)*cf
  km(10,15)=km(9,16)
  km(10,16)=-d27/d160*(-2*x4*x1+2*x4*x7+2*x7*x1-2*x7**2+2*x4*x1*pr-       &
    2*x4*x7*pr-2*x7*x1*pr+2*x7**2*pr+y4*y7-2*pr*y4*y7-y4*y1+2*pr*y4*y1-   &
    y7**2+2*pr*y7**2+y7*y1-2*pr*y7*y1)*cf
  km(10,17)=km(9,16)
  km(10,18)=km(10,16)
  km(10,19)=km(9,20)
  km(10,20)=d81/d80*(-2*x4*x1+2*x4*x7+2*x7*x1-2*x7**2+2*x4*x1*pr-         &
    2*x4*x7*pr-2*x7*x1*pr+2*x7**2*pr+y4*y7-2*pr*y4*y7-y4*y1+2*pr*y4*y1-   &
    y7**2+2*pr*y7**2+y7*y1-2*pr*y7*y1)*cf
!--------------------------------------------------------------------------
  km(11,11)=km(3,3)
  km(11,12)=km(3,4)
  km(11,13)=d3/d160*(38*x4*x7*pr-2*pr*y4**2+38*pr*y4*y7+36*x1**2*pr+      &
    36*pr*y1**2-18*x1**2+2*y4**2-38*y4*y7+x4**2-19*x4*x7-2*x4**2*pr-      &
    34*pr*y4*y1-38*pr*y7*y1-34*x4*x1*pr-38*x7*x1*pr+34*y4*y1+38*y7*y1+    &
    17*x4*x1+19*x7*x1-36*y1**2)*cf
  km(11,14)=d3/d160*(-18*x1*y4-x4*y4+y1*x4-19*y1*x7+19*y4*x7-             &
    38*pr*y4*x7+38*pr*x4*y7+38*pr*y4*x1-38*pr*y7*x1-38*x4*y1*pr+          &
    38*x7*y1*pr+18*x1*y1)*cf
  km(11,15)=d27/d32*(2*y4*y7-2*y4*y1-2*y7**2+2*y7*y1-2*pr*y4*y7+          &
    2*pr*y4*y1+2*pr*y7**2-2*pr*y7*y1-x4*x1+2*x4*x1*pr+x4*x7-2*x4*x7*pr+   &
    x7*x1-2*x7*x1*pr-x7**2+2*x7**2*pr)*cf
  km(11,16)=d27/d64*(-x4*y7+x1*y4-x1*y7+y1*x4-y1*x7-y4*x7+2*y7*x7)*cf
  km(11,17)=km(9,15)
  km(11,18)=km(9,16)
  km(11,19)=km(3,19)
  km(11,20)=km(3,20)
!--------------------------------------------------------------------------
  km(12,12)=km(4,4)
  km(12,13)=-d3/d160*(-19*x4*y7-x1*y4+x4*y4+19*x1*y7+18*y1*x4-            &
    38*pr*y4*x7+38*pr*x4*y7+38*pr*y4*x1-38*pr*y7*x1-38*x4*y1*pr+          &
    38*x7*y1*pr-18*x1*y1)*cf
  km(12,14)=d3/d160*(38*x4*x7*pr-2*pr*y4**2+38*pr*y4*y7+36*x1**2*pr+      &
    36*pr*y1**2-36*x1**2+y4**2-19*y4*y7+2*x4**2-38*x4*x7-2*x4**2*pr-      &
    34*pr*y4*y1-38*pr*y7*y1-34*x4*x1*pr-38*x7*x1*pr+17*y4*y1+19*y7*y1+    &
    34*x4*x1+38*x7*x1-18*y1**2)*cf
  km(12,15)=km(11,16)
  km(12,16)=d27/d32*(-2*x4*x1+2*x4*x7+2*x7*x1-2*x7**2+2*x4*x1*pr-         &
    2*x4*x7*pr-2*x7*x1*pr+2*x7**2*pr+y4*y7-2*pr*y4*y7-y4*y1+2*pr*y4*y1-   &
    y7**2+2*pr*y7**2+y7*y1-2*pr*y7*y1)*cf
  km(12,17)=km(9,16)
  km(12,18)=km(10,16)
  km(12,19)=km(3,20)
  km(12,20)=km(4,20)
!--------------------------------------------------------------------------
  km(13,13)=-d17/d80*(2*pr*y4**2+2*x1**2*pr+2*pr*y1**2-x1**2-2*y4**2-     &
    x4**2+2*x4**2*pr-4*pr*y4*y1-4*x4*x1*pr+4*y4*y1+2*x4*x1-2*y1**2)*cf
  km(13,14)=-d17/d80*(y1-y4)*(x1-x4)*cf
  km(13,15)=-d3/d160*(38*x4*x7*pr-36*pr*y4**2+38*pr*y4*y7+2*x1**2*pr+     &
    2*pr*y1**2-x1**2+36*y4**2-38*y4*y7+18*x4**2-19*x4*x7-36*x4**2*pr+     &
    34*pr*y4*y1-38*pr*y7*y1+34*x4*x1*pr-38*x7*x1*pr-34*y4*y1+38*y7*y1-    &
    17*x4*x1+19*x7*x1-2*y1**2)*cf
  km(13,16)=d3/d160*(-18*x1*y4+18*x4*y4+y1*x4-x1*y1-19*x4*y7+19*x1*y7+    &
    38*pr*x4*y7+38*pr*y4*x1-38*pr*y7*x1-38*pr*y4*x7+38*x7*y1*pr-          &
    38*x4*y1*pr)*cf
  km(13,17)=-d3/d160*(-16*x4*x7*pr+18*pr*y4**2-16*pr*y4*y7+2*x1**2*pr+    &
    2*pr*y1**2-x1**2-18*y4**2+16*y4*y7-9*x4**2+8*x4*x7+18*x4**2*pr-       &
    20*pr*y4*y1+16*pr*y7*y1-20*x4*x1*pr+16*x7*x1*pr+20*y4*y1-16*y7*y1+    &
    10*x4*x1-8*x7*x1-2*y1**2)*cf
  km(13,18)=-d3/d160*(-8*x4*y7-9*x1*y4+9*x4*y4+8*x1*y7-y1*x4-             &
    16*pr*y4*x7+16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+          &
    16*x7*y1*pr+x1*y1)*cf
  km(13,19)=d0
  km(13,20)=d0
!--------------------------------------------------------------------------
  km(14,14)=-d17/d80*(2*pr*y4**2+2*x1**2*pr+2*pr*y1**2-2*x1**2-y4**2-     &
    2*x4**2+2*x4**2*pr-4*pr*y4*y1-4*x4*x1*pr+2*y4*y1+4*x4*x1-y1**2)*cf
  km(14,15)=-d3/d160*(-x1*y4-18*x4*y4+18*y1*x4+x1*y1-19*y1*x7+19*y4*x7+   &
    38*pr*y4*x1-38*pr*y7*x1-38*x4*y1*pr+38*x7*y1*pr+38*pr*x4*y7-          &
    38*pr*y4*x7)*cf
  km(14,16)=-d3/d160*(38*x4*x7*pr-36*pr*y4**2+38*pr*y4*y7+2*x1**2*pr+     &
    2*pr*y1**2-2*x1**2+18*y4**2-19*y4*y7+36*x4**2-38*x4*x7-36*x4**2*pr+   &
    34*pr*y4*y1-38*pr*y7*y1+34*x4*x1*pr-38*x7*x1*pr-17*y4*y1+19*y7*y1-    &
    34*x4*x1+38*x7*x1-y1**2)*cf
  km(14,17)=d3/d160*(x1*y4-9*x4*y4+9*y1*x4-8*y1*x7+8*y4*x7-16*pr*y4*x7+   &
    16*pr*x4*y7+16*pr*y4*x1-16*pr*y7*x1-16*x4*y1*pr+16*x7*y1*pr-x1*y1)*cf
  km(14,18)=-d3/d160*(-16*x4*x7*pr+18*pr*y4**2-16*pr*y4*y7+2*x1**2*pr+    &
    2*pr*y1**2-2*x1**2-9*y4**2+8*y4*y7-18*x4**2+16*x4*x7+18*x4**2*pr-     &
    20*pr*y4*y1+16*pr*y7*y1-20*x4*x1*pr+16*x7*x1*pr+10*y4*y1-8*y7*y1+     &
    20*x4*x1-16*x7*x1-y1**2)*cf
  km(14,19)=d0
  km(14,20)=d0
!--------------------------------------------------------------------------
  km(15,15)=km(3,3)
  km(15,16)=km(3,4)
  km(15,17)=d27/d160*(-8*x4*x7*pr+8*pr*y4**2-8*pr*y4*y7+2*x1**2*pr+       &
    2*pr*y1**2-x1**2-8*y4**2+8*y4*y7-2*y7**2+2*pr*y7**2-4*x4**2+4*x4*x7-  &
    x7**2+8*x4**2*pr+2*x7**2*pr-8*pr*y4*y1+4*pr*y7*y1-8*x4*x1*pr+         &
    4*x7*x1*pr+8*y4*y1-4*y7*y1+4*x4*x1-2*x7*x1-2*y1**2)*cf
  km(15,18)=d27/d320*(-7*x4*y7-7*x1*y4+8*x4*y4+5*x1*y7-y1*x4-y1*x7-       &
    y4*x7+2*y7*x7-12*pr*y4*x7+12*pr*x4*y7+12*pr*y4*x1-12*pr*y7*x1-        &
    12*x4*y1*pr+12*x7*y1*pr+2*x1*y1)*cf
  km(15,19)=km(5,19)
  km(15,20)=km(5,20)
!--------------------------------------------------------------------------
  km(16,16)=km(4,4)
  km(16,17)=-d27/d320*(x4*y7+x1*y4-8*x4*y4+x1*y7+7*y1*x4-5*y1*x7+         &
    7*y4*x7-2*y7*x7-12*pr*y4*x7+12*pr*x4*y7+12*pr*y4*x1-12*pr*y7*x1-      &
    12*x4*y1*pr+12*x7*y1*pr-2*x1*y1)*cf
  km(16,18)=d27/d160*(-8*x4*x7*pr+8*pr*y4**2-8*pr*y4*y7+2*x1**2*pr+       &
    2*pr*y1**2-2*x1**2-4*y4**2+4*y4*y7-y7**2+2*pr*y7**2-8*x4**2+8*x4*x7-  &
    2*x7**2+8*x4**2*pr+2*x7**2*pr-8*pr*y4*y1+4*pr*y7*y1-8*x4*x1*pr+       &
    4*x7*x1*pr+4*y4*y1-2*y7*y1+8*x4*x1-4*x7*x1-y1**2)*cf
  km(16,19)=km(5,20)
  km(16,20)=km(6,20)
!--------------------------------------------------------------------------
  km(17,17)=km(3,3)
  km(17,18)=km(3,4)
  km(17,19)=km(9,19)
  km(17,20)=km(9,20)
!--------------------------------------------------------------------------
  km(18,18)=km(4,4)
  km(18,19)=km(9,20)
  km(18,20)=km(10,20)
!--------------------------------------------------------------------------
  km(19,19)=-d81/d40*(-2*x4*x7*pr+2*pr*y4**2-2*pr*y4*y7+2*x1**2*pr+       &
    2*pr*y1**2-x1**2-2*y4**2+2*y4*y7-2*y7**2+2*pr*y7**2-x4**2+x4*x7-      &
    x7**2+2*x4**2*pr+2*x7**2*pr-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-         &
    2*x7*x1*pr+2*y4*y1+2*y7*y1+x4*x1+x7*x1-2*y1**2)*cf
  km(19,20)=-d81/d80*(-x4*y7-x1*y4+2*x4*y4-x1*y7-y1*x4-y1*x7-y4*x7+       &
    2*y7*x7+2*x1*y1)*cf
!--------------------------------------------------------------------------
  km(20,20)=-d81/d40*(-2*x4*x7*pr+2*pr*y4**2-2*pr*y4*y7+2*x1**2*pr+       &
    2*pr*y1**2-2*x1**2-y4**2+y4*y7-y7**2+2*pr*y7**2-2*x4**2+2*x4*x7-      &
    2*x7**2+2*x4**2*pr+2*x7**2*pr-2*pr*y4*y1-2*pr*y7*y1-2*x4*x1*pr-       &
    2*x7*x1*pr+y4*y1+y7*y1+2*x4*x1+2*x7*x1-y1**2)*cf
!-----------------------------------LOWER TRIANGLE-------------------------
  km(2,1)=km(1,2)
  km(3,1)=km(1,3)
  km(3,2)=km(2,3)
  km(4,1)=km(1,4)
  km(4,2)=km(2,4)
  km(4,3)=km(3,4)
  km(5,1)=km(1,5)
  km(5,2)=km(2,5)
  km(5,3)=km(3,5)
  km(5,4)=km(4,5)
  km(6,1)=km(1,6)
  km(6,2)=km(2,6)
  km(6,3)=km(3,6)
  km(6,4)=km(4,6)
  km(6,5)=km(5,6)
  km(7,1)=km(1,7)
  km(7,2)=km(2,7)
  km(7,3)=km(3,7)
  km(7,4)=km(4,7)
  km(7,5)=km(5,7)
  km(7,6)=km(6,7)
  km(8,1)=km(1,8)
  km(8,2)=km(2,8)
  km(8,3)=km(3,8)
  km(8,4)=km(4,8)
  km(8,5)=km(5,8)
  km(8,6)=km(6,8)
  km(8,7)=km(7,8)
  km(9,1)=km(1,9)
  km(9,2)=km(2,9)
  km(9,3)=km(3,9)
  km(9,4)=km(4,9)
  km(9,5)=km(5,9)
  km(9,6)=km(6,9)
  km(9,7)=km(7,9)
  km(9,8)=km(8,9)
  km(10,1)=km(1,10)
  km(10,2)=km(2,10)
  km(10,3)=km(3,10)
  km(10,4)=km(4,10)
  km(10,5)=km(5,10)
  km(10,6)=km(6,10)
  km(10,7)=km(7,10)
  km(10,8)=km(8,10)
  km(10,9)=km(9,10)
  km(11,1)=km(1,11)
  km(11,2)=km(2,11)
  km(11,3)=km(3,11)
  km(11,4)=km(4,11)
  km(11,5)=km(5,11)
  km(11,6)=km(6,11)
  km(11,7)=km(7,11)
  km(11,8)=km(8,11)
  km(11,9)=km(9,11)
  km(11,10)=km(10,11)
  km(12,1)=km(1,12)
  km(12,2)=km(2,12)
  km(12,3)=km(3,12)
  km(12,4)=km(4,12)
  km(12,5)=km(5,12)
  km(12,6)=km(6,12)
  km(12,7)=km(7,12)
  km(12,8)=km(8,12)
  km(12,9)=km(9,12)
  km(12,10)=km(10,12)
  km(12,11)=km(11,12)
  km(13,1)=km(1,13)
  km(13,2)=km(2,13)
  km(13,3)=km(3,13)
  km(13,4)=km(4,13)
  km(13,5)=km(5,13)
  km(13,6)=km(6,13)
  km(13,7)=km(7,13)
  km(13,8)=km(8,13)
  km(13,9)=km(9,13)
  km(13,10)=km(10,13)
  km(13,11)=km(11,13)
  km(13,12)=km(12,13)
  km(14,1)=km(1,14)
  km(14,2)=km(2,14)
  km(14,3)=km(3,14)
  km(14,4)=km(4,14)
  km(14,5)=km(5,14)
  km(14,6)=km(6,14)
  km(14,7)=km(7,14)
  km(14,8)=km(8,14)
  km(14,9)=km(9,14)
  km(14,10)=km(10,14)
  km(14,11)=km(11,14)
  km(14,12)=km(12,14)
  km(14,13)=km(13,14)
  km(15,1)=km(1,15)
  km(15,2)=km(2,15)
  km(15,3)=km(3,15)
  km(15,4)=km(4,15)
  km(15,5)=km(5,15)
  km(15,6)=km(6,15)
  km(15,7)=km(7,15)
  km(15,8)=km(8,15)
  km(15,9)=km(9,15)
  km(15,10)=km(10,15)
  km(15,11)=km(11,15)
  km(15,12)=km(12,15)
  km(15,13)=km(13,15)
  km(15,14)=km(14,15)
  km(16,1)=km(1,16)
  km(16,2)=km(2,16)
  km(16,3)=km(3,16)
  km(16,4)=km(4,16)
  km(16,5)=km(5,16)
  km(16,6)=km(6,16)
  km(16,7)=km(7,16)
  km(16,8)=km(8,16)
  km(16,9)=km(9,16)
  km(16,10)=km(10,16)
  km(16,11)=km(11,16)
  km(16,12)=km(12,16)
  km(16,13)=km(13,16)
  km(16,14)=km(14,16)
  km(16,15)=km(15,16)
  km(17,1)=km(1,17)
  km(17,2)=km(2,17)
  km(17,3)=km(3,17)
  km(17,4)=km(4,17)
  km(17,5)=km(5,17)
  km(17,6)=km(6,17)
  km(17,7)=km(7,17)
  km(17,8)=km(8,17)
  km(17,9)=km(9,17)
  km(17,10)=km(10,17)
  km(17,11)=km(11,17)
  km(17,12)=km(12,17)
  km(17,13)=km(13,17)
  km(17,14)=km(14,17)
  km(17,15)=km(15,17)
  km(17,16)=km(16,17)
  km(18,1)=km(1,18)
  km(18,2)=km(2,18)
  km(18,3)=km(3,18)
  km(18,4)=km(4,18)
  km(18,5)=km(5,18)
  km(18,6)=km(6,18)
  km(18,7)=km(7,18)
  km(18,8)=km(8,18)
  km(18,9)=km(9,18)
  km(18,10)=km(10,18)
  km(18,11)=km(11,18)
  km(18,12)=km(12,18)
  km(18,13)=km(13,18)
  km(18,14)=km(14,18)
  km(18,15)=km(15,18)
  km(18,16)=km(16,18)
  km(18,17)=km(17,18)
  km(19,1)=km(1,19)
  km(19,2)=km(2,19)
  km(19,3)=km(3,19)
  km(19,4)=km(4,19)
  km(19,5)=km(5,19)
  km(19,6)=km(6,19)
  km(19,7)=km(7,19)
  km(19,8)=km(8,19)
  km(19,9)=km(9,19)
  km(19,10)=km(10,19)
  km(19,11)=km(11,19)
  km(19,12)=km(12,19)
  km(19,13)=km(13,19)
  km(19,14)=km(14,19)
  km(19,15)=km(15,19)
  km(19,16)=km(16,19)
  km(19,17)=km(17,19)
  km(19,18)=km(18,19)
  km(20,1)=km(1,20)
  km(20,2)=km(2,20)
  km(20,3)=km(3,20)
  km(20,4)=km(4,20)
  km(20,5)=km(5,20)
  km(20,6)=km(6,20)
  km(20,7)=km(7,20)
  km(20,8)=km(8,20)
  km(20,9)=km(9,20)
  km(20,10)=km(10,20)
  km(20,11)=km(11,20)
  km(20,12)=km(12,20)
  km(20,13)=km(13,20)
  km(20,14)=km(14,20)
  km(20,15)=km(15,20)
  km(20,16)=km(16,20)
  km(20,17)=km(17,20)
  km(20,18)=km(18,20)
  km(20,19)=km(19,20)
 RETURN
END SUBROUTINE stiff10


 SUBROUTINE POLATEV6(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,LI,UI,VI, &
                     NO,RLAT,RLON,CROT,SROT,IBO,LO,UO,VO,IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 71314 $
!
! SUBPROGRAM:  POLATEV6   INTERPOLATE VECTOR FIELDS (BUDGET)
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM PERFORMS BUDGET INTERPOLATION
!           FROM ANY GRID TO ANY GRID FOR VECTOR FIELDS.
!           IT REQUIRES A GRID FOR THE OUTPUT FIELDS (KGDSO(1)>=0).
!           THE ALGORITHM SIMPLY COMPUTES (WEIGHTED) AVERAGES
!           OF NEIGHBOR POINTS ARRANGED IN A SQUARE BOX
!           CENTERED AROUND EACH OUTPUT GRID POINT AND STRETCHING
!           NEARLY HALFWAY TO EACH OF THE NEIGHBORING GRID POINTS.
!           OPTIONS ALLOW CHOICES OF NUMBER OF POINTS IN EACH RADIUS
!           FROM THE CENTER POINT (IPOPT(1)) WHICH DEFAULTS TO 2
!           (IF IPOPT(1)=-1) MEANING THAT 25 POINTS WILL BE AVERAGED;
!           FURTHER OPTIONS ARE THE RESPECTIVE WEIGHTS FOR THE RADIUS
!           POINTS STARTING AT THE CENTER POINT (IPOPT(2:2+IPOPT(1))
!           WHICH DEFAULTS TO ALL 1 (IF IPOPT(1)=-1 OR IPOPT(2)=-1).
!           ANOTHER OPTION IS THE MINIMUM PERCENTAGE FOR MASK,
!           I.E. PERCENT VALID INPUT DATA REQUIRED TO MAKE OUTPUT DATA,
!           (IPOPT(3+IPOPT(1)) WHICH DEFAULTS TO 50 (IF -1).
!           ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
!           THE GRIDS ARE DEFINED BY THEIR GRID DESCRIPTION SECTIONS
!           (PASSED IN INTEGER FORM AS DECODED BY SUBPROGRAM W3FI63).
!           THE CURRENT CODE RECOGNIZES THE FOLLOWING PROJECTIONS:
!             (KGDS(1)=000) EQUIDISTANT CYLINDRICAL
!             (KGDS(1)=001) MERCATOR CYLINDRICAL
!             (KGDS(1)=003) LAMBERT CONFORMAL CONICAL
!             (KGDS(1)=004) GAUSSIAN CYLINDRICAL (SPECTRAL NATIVE)
!             (KGDS(1)=005) POLAR STEREOGRAPHIC AZIMUTHAL
!             (KGDS(1)=203) ROTATED EQUIDISTANT CYLINDRICAL (E-STAGGER)
!             (KGDS(1)=205) ROTATED EQUIDISTANT CYLINDRICAL (B-STAGGER)
!           WHERE KGDS COULD BE EITHER INPUT KGDSI OR OUTPUT KGDSO.
!           THE INPUT AND OUTPUT VECTORS ARE ROTATED SO THAT THEY ARE
!           EITHER RESOLVED RELATIVE TO THE DEFINED GRID
!           IN THE DIRECTION OF INCREASING X AND Y COORDINATES
!           OR RESOLVED RELATIVE TO EASTERLY AND NORTHERLY DIRECTIONS,
!           AS DESIGNATED BY THEIR RESPECTIVE GRID DESCRIPTION SECTIONS.
!           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS
!           AND THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED
!           ALONG WITH THEIR VECTOR ROTATION PARAMETERS.
!           INPUT BITMAPS WILL BE INTERPOLATED TO OUTPUT BITMAPS.
!           OUTPUT BITMAPS WILL ALSO BE CREATED WHEN THE OUTPUT GRID
!           EXTENDS OUTSIDE OF THE DOMAIN OF THE INPUT GRID.
!           THE OUTPUT FIELD IS SET TO 0 WHERE THE OUTPUT BITMAP IS OFF.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
! 1999-04-08  IREDELL  SPLIT IJKGDS INTO TWO PIECES
! 2001-06-18  IREDELL  INCLUDE MINIMUM MASK PERCENTAGE OPTION
! 2002-01-17  IREDELL  SAVE DATA FROM LAST CALL FOR OPTIMIZATION
! 2015-01-27  GAYNO    REPLACE CALLS TO GDSWIZ WITH NEW MERGED
!                      ROUTINE GDSWZD.
!
! USAGE:    CALL POLATEV6(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,LI,UI,VI,
!    &                    NO,RLAT,RLON,CROT,SROT,IBO,LO,UO,VO,IRET)
!
!   INPUT ARGUMENT LIST:
!     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
!                IPOPT(1) IS NUMBER OF RADIUS POINTS
!                (DEFAULTS TO 2 IF IPOPT(1)=-1);
!                IPOPT(2:2+IPOPT(1)) ARE RESPECTIVE WEIGHTS
!                (DEFAULTS TO ALL 1 IF IPOPT(1)=-1 OR IPOPT(2)=-1).
!                IPOPT(3+IPOPT(1)) IS MINIMUM PERCENTAGE FOR MASK
!                (DEFAULTS TO 50 IF IPOPT(3+IPOPT(1)=-1)
!     KGDSI    - INTEGER (200) INPUT GDS PARAMETERS AS DECODED BY W3FI63
!     KGDSO    - INTEGER (200) OUTPUT GDS PARAMETERS
!     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
!     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
!     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
!     IBI      - INTEGER (KM) INPUT BITMAP FLAGS
!     LI       - LOGICAL*1 (MI,KM) INPUT BITMAPS (IF SOME IBI(K)=1)
!     UI       - REAL (MI,KM) INPUT U-COMPONENT FIELDS TO INTERPOLATE
!     VI       - REAL (MI,KM) INPUT V-COMPONENT FIELDS TO INTERPOLATE
!
!   OUTPUT ARGUMENT LIST:
!     NO       - INTEGER NUMBER OF OUTPUT POINTS
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES
!     CROT     - REAL (NO) VECTOR ROTATION COSINES
!     SROT     - REAL (NO) VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
!     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
!     UO       - REAL (MO,KM) OUTPUT U-COMPONENT FIELDS INTERPOLATED
!     VO       - REAL (MO,KM) OUTPUT V-COMPONENT FIELDS INTERPOLATED
!     IRET     - INTEGER RETURN CODE
!                0    SUCCESSFUL INTERPOLATION
!                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
!                3    UNRECOGNIZED OUTPUT GRID
!                31   INVALID UNDEFINED OUTPUT GRID
!                32   INVALID BUDGET METHOD PARAMETERS
!
! SUBPROGRAMS CALLED:
!   GDSWZD       GRID DESCRIPTION SECTION WIZARD
!   IJKGDS0      SET UP PARAMETERS FOR IJKGDS1
!   (IJKGDS1)    RETURN FIELD POSITION FOR A GIVEN GRID POINT
!   (MOVECT)     MOVE A VECTOR ALONG A GREAT CIRCLE
!   POLFIXV      MAKE MULTIPLE POLE VECTOR VALUES CONSISTENT
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 USE GDSWZD_MOD
!
 IMPLICIT NONE
!
 INTEGER,         INTENT(IN   ):: IPOPT(20), IBI(KM)
 INTEGER,         INTENT(IN   ):: KM, MI, MO
 INTEGER,         INTENT(IN   ):: KGDSI(200),KGDSO(200)
 INTEGER,         INTENT(  OUT):: IRET, NO, IBO(KM)
!
 LOGICAL*1,       INTENT(IN   ):: LI(MI,KM)
 LOGICAL*1,       INTENT(  OUT):: LO(MO,KM)
!
 REAL,            INTENT(IN   ):: UI(MI,KM),VI(MI,KM)
 REAL,            INTENT(INOUT):: RLAT(MO),RLON(MO)
 REAL,            INTENT(  OUT):: UO(MO,KM),VO(MO,KM)
 REAL,            INTENT(  OUT):: CROT(MO),SROT(MO)
!
 REAL,            PARAMETER    :: FILL=-9999.
!
 INTEGER                       :: IJKGDS1, N11(MO), IJKGDSA(20)
 INTEGER                       :: IB, JB, I1, J1
 INTEGER                       :: K, LB, LSW, MP, N, NV
 INTEGER,                 SAVE :: MIX=-1,KGDSIX(200)=-1
 INTEGER                       :: NB, NB1, NB2, NB3, NB4
!
 REAL                          :: C11(MO),S11(MO)
 REAL,        ALLOCATABLE,SAVE :: CROI(:),SROI(:)
 REAL                          :: CM11, SM11, PMP
 REAL                          :: U11, V11, UROT, VROT
 REAL                          :: WB, WO(MO,KM), XI, YI
 REAL                          :: RLOB(MO),RLAB(MO)
 REAL,        ALLOCATABLE,SAVE :: RLOI(:),RLAI(:)
 REAL                          :: XPTS(MO),YPTS(MO)
 REAL,        ALLOCATABLE,SAVE :: XPTI(:),YPTI(:)
 REAL                          :: XPTB(MO),YPTB(MO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
 IRET=0
 IF(KGDSO(1).GE.0) THEN
   CALL GDSWZD(KGDSO, 0,MO,FILL,XPTS,YPTS,RLON,RLAT,NO,CROT,SROT)
   IF(NO.EQ.0) IRET=3
 ELSE
   IRET=31
 ENDIF
 IF(ANY(KGDSI.NE.KGDSIX)) THEN
   IF(MIX.NE.MI) THEN
     IF(MIX.GE.0) DEALLOCATE(XPTI,YPTI,RLOI,RLAI,CROI,SROI)
     ALLOCATE(XPTI(MI),YPTI(MI),RLOI(MI),RLAI(MI),CROI(MI),SROI(MI))
     MIX=MI
   ENDIF
   CALL GDSWZD(KGDSI, 0,MI,FILL,XPTI,YPTI,RLOI,RLAI,NV,CROI,SROI)
   KGDSIX=KGDSI
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SET PARAMETERS
 NB1=IPOPT(1)
 IF(NB1.EQ.-1) NB1=2
 IF(IRET.EQ.0.AND.NB1.LT.0) IRET=32
 LSW=1
 IF(IPOPT(1).EQ.-1.OR.IPOPT(2).EQ.-1) LSW=0
 IF(IRET.EQ.0.AND.LSW.EQ.1.AND.NB1.GT.15) IRET=32
 MP=IPOPT(3+IPOPT(1))
 IF(MP.EQ.-1.OR.MP.EQ.0) MP=50
 IF(MP.LT.0.OR.MP.GT.100) IRET=32
 PMP=MP*0.01
 IF(IRET.EQ.0) THEN
   NB2=2*NB1+1
   NB3=NB2*NB2
   NB4=NB3
   IF(LSW.EQ.1) THEN
     NB4=IPOPT(2)
     DO IB=1,NB1
       NB4=NB4+8*IB*IPOPT(2+IB)
     ENDDO
   ENDIF
 ELSE
   NB2=0
   NB3=0
   NB4=0
 ENDIF
 DO K=1,KM
   DO N=1,NO
     UO(N,K)=0
     VO(N,K)=0
     WO(N,K)=0.
   ENDDO
 ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  LOOP OVER SAMPLE POINTS IN OUTPUT GRID BOX
 CALL IJKGDS0(KGDSI,IJKGDSA)
 DO NB=1,NB3
!  LOCATE INPUT POINTS AND COMPUTE THEIR WEIGHTS AND ROTATIONS
   JB=(NB-1)/NB2-NB1
   IB=NB-(JB+NB1)*NB2-NB1-1
   LB=MAX(ABS(IB),ABS(JB))
   WB=1
   IF(LSW.EQ.1) WB=IPOPT(2+LB)
   IF(WB.NE.0) THEN
     DO N=1,NO
       XPTB(N)=XPTS(N)+IB/REAL(NB2)
       YPTB(N)=YPTS(N)+JB/REAL(NB2)
     ENDDO
     CALL GDSWZD(KGDSO, 1,NO,FILL,XPTB,YPTB,RLOB,RLAB,NV)
     CALL GDSWZD(KGDSI,-1,NO,FILL,XPTB,YPTB,RLOB,RLAB,NV)
     IF(IRET.EQ.0.AND.NV.EQ.0.AND.LB.EQ.0) IRET=2
     DO N=1,NO
       XI=XPTB(N)
       YI=YPTB(N)
       IF(XI.NE.FILL.AND.YI.NE.FILL) THEN
         I1=NINT(XI)
         J1=NINT(YI)
         N11(N)=IJKGDS1(I1,J1,IJKGDSA)
         IF(N11(N).GT.0) THEN
           CALL MOVECT(RLAI(N11(N)),RLOI(N11(N)),RLAT(N),RLON(N),CM11,SM11)
           C11(N)=CM11*CROI(N11(N))+SM11*SROI(N11(N))
           S11(N)=SM11*CROI(N11(N))-CM11*SROI(N11(N))
         ENDIF
       ELSE
         N11(N)=0
       ENDIF
     ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  INTERPOLATE WITH OR WITHOUT BITMAPS
     DO K=1,KM
       DO N=1,NO
         IF(N11(N).GT.0) THEN
           IF(IBI(K).EQ.0.OR.LI(N11(N),K)) THEN
             U11=C11(N)*UI(N11(N),K)-S11(N)*VI(N11(N),K)
             V11=S11(N)*UI(N11(N),K)+C11(N)*VI(N11(N),K)
             UO(N,K)=UO(N,K)+WB*U11
             VO(N,K)=VO(N,K)+WB*V11
             WO(N,K)=WO(N,K)+WB
           ENDIF
         ENDIF
       ENDDO
     ENDDO
   ENDIF
 ENDDO  ! NB LOOP
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE OUTPUT BITMAPS AND FIELDS
 DO K=1,KM
   IBO(K)=IBI(K)
   DO N=1,NO
     LO(N,K)=WO(N,K).GE.PMP*NB4
     IF(LO(N,K)) THEN
       UO(N,K)=UO(N,K)/WO(N,K)
       VO(N,K)=VO(N,K)/WO(N,K)
       UROT=CROT(N)*UO(N,K)-SROT(N)*VO(N,K)
       VROT=SROT(N)*UO(N,K)+CROT(N)*VO(N,K)
       UO(N,K)=UROT
       VO(N,K)=VROT
     ELSE
       IBO(K)=1
       UO(N,K)=0.
       VO(N,K)=0.
     ENDIF
   ENDDO
 ENDDO
 IF(KGDSO(1).EQ.0) CALL POLFIXV(NO,MO,KM,RLAT,RLON,IBO,LO,UO,VO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE POLATEV6


SUBROUTINE p95(input_file,output_file)
!-------------------------------------------------------------------------
! Program 9.5 Plane strain consolidation analysis of a Biot elastic solid
!             using 8-node rectangular quadrilaterals for displacements
!             coupled to 4-node rectangular quadrilaterals for pressures.
!             Freedoms numbered in order u-v-uw. Incremental load version.
!             No global stiffness matrix assembly.
!             Diagonally preconditioned conjugate gradient solver.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::cg_iters,cg_limit,i,iel,j,k,loaded_nodes,ndim=2,ndof=16,nels,   &
   neq,nip=4,nlen,nlfp,nls,nn,nod=8,nodf=4,nodof=3,npri,nprops=4,np_types,&
   nr,nres,nst=3,nstep,ntot=20,nxe,nye
 LOGICAL::cg_converged
 REAL(iwp)::alpha,beta,cg_tol,det,dtim,one=1.0_iwp,theta,time,tot_load,up,&
   zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),nf(:,:),no(:),    &
   num(:)
 REAL(iwp),ALLOCATABLE::al(:),ans(:),bee(:,:),c(:,:),coord(:,:),d(:),     &
   dee(:,:),der(:,:),derf(:,:),deriv(:,:),derivf(:,:),diag_precon(:),     &
   eld(:),fun(:),funf(:),gc(:),g_coord(:,:),jac(:,:),kay(:,:),ke(:,:),    &
   km(:,:),kc(:,:),lf(:,:),loads(:),p(:),points(:,:),prop(:,:),sigma(:),  &
   storke(:,:,:),u(:),val(:,:),vol(:),volf(:,:),store_kc(:,:,:),          &
   weights(:),x(:),xnew(:),x_coords(:),y_coords(:),phi0(:),phi1(:)
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,cg_tol,cg_limit,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(dee(nst,nst),points(nip,ndim),coord(nod,ndim),derivf(ndim,nodf),&
   jac(ndim,ndim),kay(ndim,ndim),der(ndim,nod),deriv(ndim,nod),           &
   derf(ndim,nodf),funf(nodf),bee(nst,ndof),km(ndof,ndof),kc(nodf,nodf),  &
   g_g(ntot,nels),ke(ntot,ntot),c(ndof,nodf),fun(nod),x_coords(nxe+1),    &
   store_kc(nodf,nodf,nels),y_coords(nye+1),vol(ndof),nf(nodof,nn),       &
   g(ntot),volf(ndof,nodf),g_coord(ndim,nn),g_num(nod,nels),num(nod),     &
   weights(nip),storke(ntot,ntot,nels),etype(nels),phi0(nodf),phi1(nodf), &
   prop(nprops,np_types),gc(ndim),sigma(nst),eld(ndof))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords
 READ(10,*)dtim,nstep,theta,npri,nres
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(loads(0:neq),ans(0:neq),p(0:neq),x(0:neq),xnew(0:neq),u(0:neq), &
   diag_precon(0:neq),d(0:neq))
 READ(10,*)loaded_nodes
 ALLOCATE(no(loaded_nodes),val(loaded_nodes,ndim))
 READ(10,*)(no(i),val(i,:),i=1,loaded_nodes)
 READ(10,*)nlfp
 ALLOCATE(lf(2,nlfp))
 READ(10,*)lf
 nls=FLOOR(lf(1,nlfp)/dtim)
 IF(nstep>nls)nstep=nls
 ALLOCATE(al(nstep))
 CALL load_function(lf,dtim,al)
!-----------------------loop the elements to set up element data----------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'x')
   g(1:15:2)=nf(1,num(:))
   g(2:16:2)=nf(2,num(:))
   g(17:20)=nf(3,num(1:7:2))
   g_g(:,iel)=g
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 WRITE(11,'(A,I5,A)')" There are",neq," equations"
 loads=zero
 p=zero
 xnew=zero
 diag_precon=zero
 CALL sample(element,points,weights)
!----------element matrix integration, storage and preconditioner---------
 elements_2: DO iel=1,nels
   kay=zero
   DO i=1,ndim
     kay(i,i)=prop(i,etype(iel))
   END DO
   CALL deemat(dee,prop(3,etype(iel)),prop(4,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   c=zero
   kc=zero
   gauss_points_1: DO i=1,nip
!-----------------------elastic solid contribution------------------------
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     vol(:)=bee(1,:)+bee(2,:)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
!-----------------------fluid contribution--------------------------------
     CALL shape_fun(funf,points,i)
     CALL shape_der(derf,points,i)
     derivf=MATMUL(jac,derf)
     kc=kc+MATMUL(MATMUL(TRANSPOSE(derivf),kay),derivf)*det*weights(i)*dtim
     CALL cross_product(vol,funf,volf)
     c=c+volf*det*weights(i)
   END DO gauss_points_1
   store_kc(:,:,iel)=kc
   CALL formke(km,kc,c,ke,theta)
   storke(:,:,iel)=ke
   DO k=1,ndof
     diag_precon(g(k))=diag_precon(g(k))+theta*km(k,k)
   END DO
   DO k=1,nodf
     diag_precon(g(ndof+k))=diag_precon(g(ndof+k))-theta*theta*kc(k,k)
   END DO
 END DO elements_2
 diag_precon(1:)=one/diag_precon(1:)
 diag_precon(0)=zero
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(/A,I5)')" Results at node",nres
 WRITE(11,'(4X,A)')                                                       &
   "time        load        x-disp      y-disp   porepressure  cg iters"
 WRITE(11,'(5E12.4)')0.0,0.0,loads(nf(:,nres))
 time_steps: DO j=1,nstep
   tot_load=SUM(al(1:j))
   time=j*dtim
   ans=zero
   elements_3: DO iel=1,nels
     g=g_g(:,iel)
     kc=store_kc(:,:,iel)
     phi0=loads(g(ndof+1:))   ! gather
     phi1=MATMUL(kc,phi0)
     ans(g(ndof+1:))=ans(g(ndof+1:))+phi1
   END DO elements_3
   ans(0)=zero
   DO i=1,loaded_nodes
     ans(nf(1:2,no(i)))=val(i,:)*al(j)
   END DO
   d=diag_precon*ans
   p=d
   x=zero
   cg_iters=0
!-----------------------pcg equation solution-----------------------------
   pcg: DO
     cg_iters=cg_iters+1
     u=zero
     elements_4: DO iel=1,nels
       g=g_g(:,iel)
       ke=storke(:,:,iel)
       u(g)=u(g)+MATMUL(ke,p(g))
     END DO elements_4
     up=DOT_PRODUCT(ans,d)
     alpha=up/DOT_PRODUCT(p,u)
     xnew=x+p*alpha
     ans=ans-u*alpha
     d=diag_precon*ans
     beta=DOT_PRODUCT(ans,d)/up
     p=d+p*beta
     CALL checon(xnew,x,cg_tol,cg_converged)
     IF(cg_converged.OR.cg_iters==cg_limit)EXIT
   END DO pcg
   ans=xnew
   ans(0)=zero
   loads=loads+ans
   loads(0)=zero
   IF(j/npri*npri==j)WRITE(11,'(5E12.4,I7)')                              &
     time,tot_load,loads(nf(:,nres)),cg_iters
!-----------------------recover stresses at nip integrating points--------
!   nip=1DEALLOCATE(points,weights)
!   ALLOCATE(points(nip,ndim),weights(nip))
!   CALL sample(element,points,weights)
!   WRITE(11,'(A,I2,A)')" The integration point (nip=",nip,") stresses are:"
!   WRITE(11,'(A,A)')" Element x-coord     y-coord",                       &
!                    "     sig_x       sig_y       tau_xy"
!   elements_5: DO iel=1,nelsnum=g_num(:,iel)
!     coord=TRANSPOSE(g_coord(:,num))g=g_g(:,iel)eld=loads(g(:ndof))
!     CALL deemat(dee,prop(3,etype(iel)),prop(4,etype(iel)))
!     gauss_pts_2: DO i=1,nip
!       CALL shape_fun(fun,points,i)CALL shape_der(der,points,i)
!       gc=MATMUL(fun,coord)jac=MATMUL(der,coord)CALL invert(jac)
!       deriv=MATMUL(jac,der)CALL beemat(bee,deriv)
!       sigma=MATMUL(dee,MATMUL(bee,eld))
!       IF(j/npri*npri==j)WRITE(11,'(I5,6E12.4)')iel,gc,sigma
!     END DO gauss_pts_2
!   END DO elements_5
 END DO time_steps
 CALL dismsh(loads,nf,0.05_iwp,g_coord,g_num,argv,nlen,13)
 CALL vecmsh(loads,nf,0.05_iwp,0.1_iwp,g_coord,g_num,argv,nlen,14)

END SUBROUTINE p95


SUBROUTINE K_Elast2TrigLinear(eNum)
   USE PrecTypes
   USE GlobalData
   IMPLICIT NONE

   ! -------------------------------------------------------------------------
   ! NAME:   K_Elast2TrigLinear
   ! PARENT: Mat_Elast2TrigLinear
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Calculate stiffness matrix a triangular linear element for
   !         two-dimensional elastostatic and thermo-elastostatic problems.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   INTEGER, INTENT(IN) :: eNum

   INTEGER :: i,j,k,l

   ! Variables used for integrations of triangular linear elements
   REAL(dp) :: a1, a2, a3, b1, b2, b3, c1, c2, c3, Delta, Delta2, Delta4
   REAL(dp) :: coef_b1, coef_c1, coef_b2, coef_c2, coef_b3, coef_c3
   REAL(dp) :: a1_b1xg_c1yg, a2_b2xg_c2yg, a3_b3xg_c3yg
   REAL(dp) :: x1, x2, x3, y1, y2, y3, xg, yg
   REAL(dp) :: Dm(3,3)
   REAL(dp) :: Bm1(3,2),      Bm2(3,2),      Bm3(3,2)
   REAL(dp) :: Bm1_T(2,3),    Bm2_T(2,3),    Bm3_T(2,3)
   REAL(dp) :: Bm1_T_Dm(2,3), Bm2_T_Dm(2,3), Bm3_T_Dm(2,3)

   REAL(dp) :: Yng, Pssn, coef
   INTEGER  :: n1, n2, n3

   Ktrig = 0.0

   Yng  = E( emtype(eNum) )  ! Young's modulus
   Pssn = v( emtype(eNum) )  ! Poisson's ration
   !       E
   !   ------------
   !   (1+v)(1-2v)
   coef = Yng / (( 1.0 + Pssn )*(1.0 - 2.0 * Pssn))

   ! [D] matrix
   !
   !            E      |  1-v     v      0      |
   ! [D] = ----------- |   v     1-v     0      |
   !       (1+v)(1-2v) |   0      0   (1-2v)/2  |
   Dm(1,1) = 1.0 - Pssn
   Dm(1,2) = Pssn
   Dm(1,3) = 0.0
   Dm(2,1) = Pssn
   Dm(2,2) = 1.0 - Pssn
   Dm(2,3) = 0.0
   Dm(3,1) = 0.0
   Dm(3,2) = 0.0
   Dm(3,3) = 0.5 - Pssn
   Dm = coef * Dm

   Bm1 = 0.0
   Bm2 = 0.0
   Bm3 = 0.0

   ! Global node numbers of the element under consideration
   n1 = elm(eNum,1)
   n2 = elm(eNum,2)
   n3 = elm(eNum,3)

   ! Coordinates of node 1
   x1 = x( n1 )
   y1 = y( n1 )

   ! Coordinates of node 2
   x2 = x( n2 )
   y2 = y( n2 )

   ! Coordinates of node 3
   x3 = x( n3 )
   y3 = y( n3 )

   a1 = x2*y3 - x3*y2;   b1 = y2 - y3;   c1 = x3 - x2
   a2 = x3*y1 - x1*y3;   b2 = y3 - y1;   c2 = x1 - x3
   a3 = x1*y2 - x2*y1;   b3 = y1 - y2;   c3 = x2 - x1

   Delta2 = a1 + a2 + a3
   Delta  = Delta2 * 0.5_dp

   !         |  ∂N1/∂x    0     |
   ! [B1] =  |   0      ∂N1/∂y  |
   !         |  ∂N1/∂y  ∂N1/∂x  |
   Bm1(1,1) = b1
   Bm1(2,2) = c1
   Bm1(3,1) = c1
   Bm1(3,2) = b1

   !         |  ∂N2/∂x    0     |
   ! [B2] =  |   0      ∂N2/∂y  |
   !         |  ∂N2/∂y  ∂N2/∂x  |
   Bm2(1,1) = b2
   Bm2(2,2) = c2
   Bm2(3,1) = c2
   Bm2(3,2) = b2

   !         |  ∂N3/∂x    0     |
   ! [B3] =  |   0      ∂N3/∂y  |
   !         |  ∂N3/∂y  ∂N3/∂x  |
   Bm3(1,1) = b3
   Bm3(2,2) = c3
   Bm3(3,1) = c3
   Bm3(3,2) = b3

   Bm1 = Bm1/Delta2
   Bm2 = Bm2/Delta2
   Bm3 = Bm3/Delta2

   ! transpositions of [B1], [B2], [B3]
   Bm1_T = TRANSPOSE(Bm1)
   Bm2_T = TRANSPOSE(Bm2)
   Bm3_T = TRANSPOSE(Bm3)

   Bm1_T_Dm = MATMUL(Bm1_T, Dm)
   Bm2_T_Dm = MATMUL(Bm2_T, Dm)
   Bm3_T_Dm = MATMUL(Bm3_T, Dm)

   ! [K11] = [B1]^T [D] [B1]
   ! [K12] = [B1]^T [D] [B2]
   ! [K13] = [B1]^T [D] [B3]
   Ktrig(1,1,:,:) = MATMUL( Bm1_T_Dm, Bm1 ) * Delta
   Ktrig(1,2,:,:) = MATMUL( Bm1_T_Dm, Bm2 ) * Delta
   Ktrig(1,3,:,:) = MATMUL( Bm1_T_Dm, Bm3 ) * Delta

   ! [K21] = [B2]^T [D] [B1]
   ! [K22] = [B2]^T [D] [B2]
   ! [K23] = [B2]^T [D] [B3]
   Ktrig(2,1,:,:) = MATMUL( Bm2_T_Dm, Bm1 ) * Delta
   Ktrig(2,2,:,:) = MATMUL( Bm2_T_Dm, Bm2 ) * Delta
   Ktrig(2,3,:,:) = MATMUL( Bm2_T_Dm, Bm3 ) * Delta

   ! [K31] = [B3]^T [D] [B1]
   ! [K32] = [B3]^T [D] [B2]
   ! [K33] = [B3]^T [D] [B3]
   Ktrig(3,1,:,:) = MATMUL( Bm3_T_Dm, Bm1 ) * Delta
   Ktrig(3,2,:,:) = MATMUL( Bm3_T_Dm, Bm2 ) * Delta
   Ktrig(3,3,:,:) = MATMUL( Bm3_T_Dm, Bm3 ) * Delta

   Ktrig = Ktrig * thickness(eNum)

   IF (pcode == 3) THEN
      xg = (x1 + x2 + x3) / 3.0_dp
      yg = (y1 + y2 + y3) / 3.0_dp
      coef = alpha( emtype(eNum) )*Yng / (1 - 2*Pssn)
      Delta4 = Delta2 + Delta2
      coef = coef / Delta4
      coef_b1 = coef * b1
      coef_c1 = coef * c1
      coef_b2 = coef * b2
      coef_c2 = coef * c2
      coef_b3 = coef * b3
      coef_c3 = coef * c3
      a1_b1xg_c1yg = a1 + b1*xg + c1*yg
      a2_b2xg_c2yg = a2 + b2*xg + c2*yg
      a3_b3xg_c3yg = a3 + b3*xg + c3*yg

      ! stored as Thtrig(node, direction, node)
      Thtrig(1,1,1) = coef_b1 * a1_b1xg_c1yg
      Thtrig(1,1,2) = coef_b1 * a2_b2xg_c2yg
      Thtrig(1,1,3) = coef_b1 * a3_b3xg_c3yg
      Thtrig(1,2,1) = coef_c1 * a1_b1xg_c1yg
      Thtrig(1,2,2) = coef_c1 * a2_b2xg_c2yg
      Thtrig(1,2,3) = coef_c1 * a3_b3xg_c3yg
      Thtrig(2,1,1) = coef_b2 * a1_b1xg_c1yg
      Thtrig(2,1,2) = coef_b2 * a2_b2xg_c2yg
      Thtrig(2,1,3) = coef_b2 * a3_b3xg_c3yg
      Thtrig(2,2,1) = coef_c2 * a1_b1xg_c1yg
      Thtrig(2,2,2) = coef_c2 * a2_b2xg_c2yg
      Thtrig(2,2,3) = coef_c2 * a3_b3xg_c3yg
      Thtrig(3,1,1) = coef_b3 * a1_b1xg_c1yg
      Thtrig(3,1,2) = coef_b3 * a2_b2xg_c2yg
      Thtrig(3,1,3) = coef_b3 * a3_b3xg_c3yg
      Thtrig(3,2,1) = coef_c3 * a1_b1xg_c1yg
      Thtrig(3,2,2) = coef_c3 * a2_b2xg_c2yg
      Thtrig(3,2,3) = coef_c3 * a3_b3xg_c3yg
   END IF

   RETURN
END SUBROUTINE K_Elast2TrigLinear


      subroutine ch_rtmusk

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine routes a daily flow through a reach using the
!!    Muskingum method

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ch_d(:)     |m             |average depth of main channel
!!    ch_n(2,:)   |none          |Manning"s "n" value for the main channel
!!    ch_s(2,:)   |m/m           |average slope of main channel
!!    chside(:)   |none          |change in horizontal distance per unit
!!                               |change in vertical distance on channel side
!!                               |slopes; always set to 2 (slope=1/2)
!!    flwin(:)    |m^3 H2O       |flow into reach on previous day
!!    flwout(:)   |m^3 H2O       |flow out of reach on previous day
!!    i           |none          |current day of simulation
!!    pet_day     |mm H2O        |potential evapotranspiration
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    flwin(:)    |m^3 H2O       |flow into reach on current day
!!    flwout(:)   |m^3 H2O       |flow out of reach on current day
!!    rcharea     |m^2           |cross-sectional area of flow
!!    rchdep      |m             |depth of flow on day
!!    rtevp       |m^3 H2O       |evaporation from reach on day
!!    rttime      |hr            |reach travel time
!!    rttlc       |m^3 H2O       |transmission losses from reach on day
!!    rtwtr       |m^3 H2O       |water leaving reach on day
!!    sdti        |m^3/s         |average flow on day in reach
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    c           |none          |inverse of channel side slope
!!    c1          |
!!    c2          |
!!    c3          |
!!    c4          |m^3 H2O       |
!!    det         |hr            |time step (24 hours)
!!    jrch        |none          |reach number
!!    nn          |              |number of subdaily computation points for stable
!!                               |routing in the muskingum routing method
!!    p           |m             |wetted perimeter
!!    rh          |m             |hydraulic radius
!!    tbase       |none          |flow duration (fraction of 24 hr)
!!    topw        |m             |top width of main channel
!!    vol         |m^3 H2O       |volume of water in reach at beginning of
!!                               |day
!!    wtrin       |m^3 H2O       |water entering reach on day
!!    xkm         |hr            |storage time constant for the reach on
!!                               |current day
!!    yy          |none          |variable to hold intermediate calculation
!!                               |value
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Sqrt
!!    SWAT: Qman

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

!!    code provided by Dr. Valentina Krysanova, Pottsdam Institute for
!!    Climate Impact Research, Germany
!!    Modified by Balaji Narasimhan
!!    Spatial Sciences Laboratory, Texas A&M University

      use basin_module
      use channel_data_module
      use channel_module
      use hydrograph_module, only : ob, icmd, jrch, isdch
      use time_module
      use channel_velocity_module
      use sd_channel_module
      use climate_module

      implicit none

      integer :: nn        !none              |number of subdaily computation points for stable
                           !                  |routing in the muskingum routing method
      integer :: ii        !none              |counter
      integer :: i         !none              |current day of simulation
      real :: xkm          !hr                |storage time constant for the reach on
                           !                  |current day
      real :: det          !hr                |time step (24 hours)
      real :: yy           !none              |variable to hold intermediate calculation
                           !                  |value
      real :: c1           !units             |description
      real :: c2           !units             |description
      real :: c3           !units             |description
      real :: c4           !m^3 H2O           |
      real :: p            !m                 |wetted perimeter
      real :: vol          !m^3 H2O           |volume of water in reach at beginning of
                           !                  |day
      real :: c            !none              |inverse of channel side slope
      real :: rh           !m                 |hydraulic radius
      real :: topw         !m                 |top width of main channel
      real :: msk1         !units             |description
      real :: msk2         !units             |description
      real :: detmax       !units             |description
      real :: detmin       !units             |description
      real :: qinday       !units             |description
      real :: qoutday      !units             |description
	  real :: volrt        !units             |description
      real :: maxrt        !units             |description
      real :: adddep       !units             |description
      real :: addp         !units             |description
      real :: addarea      !units             |description
	  real :: rttlc1       !units             |description
      real :: rttlc2       !units             |description
      real :: rtevp1       !units             |description
      real :: rtevp2       !units             |description
      real :: qman         !m^3/s or m/s      |flow rate or flow velocity
      real :: vc           !m/s               |flow velocity in reach
      real :: aaa          !units             |description
      real :: sum_rttlc    !                  |           !! Van Tam Nguyen 10/2018
      real :: sum_rtevp    !                  |           !! Van Tam Nguyen 10/2018

      real :: inflo        !m^3           |inflow water volume
      real :: xs_area      !m^2           |cross section area of channel
      real :: dep_flo      !m             |depth of flow
      real :: perim_wet    !m             |wetted perimeter
      real :: ttime        !hr            |travel time through the reach
      real :: t_inc        !hr            |time in routing step - 1/time%step
      real :: outflo       !m^3           |outflow water volume
      real :: tl           !m^3           |transmission losses during time step
      real :: trans_loss   !m^3           |transmission losses during day
      real :: rate_flo     !m^3/s         |flow rate
      real :: ev           !m^3           |evaporation during time step
      real :: evap         !m^3           |evaporation losses during day
      integer :: iwst

      jrch = isdch
      jhyd = sd_dat(jrch)%hyd

      qinday = 0
      qoutday = 0
      det = 24.
      sum_rttlc = 0.0   !! Van Tam Nguyen 10/2018
      sum_rtevp = 0.0   !! Van Tam Nguyen 10/2018
      ch(jrch)%chfloodvol = 0.

      !! Compute storage time constant for reach (msk_co1 + msk_co2 = 1.)
	  msk1 = bsn_prm%msk_co1 / (bsn_prm%msk_co1 + bsn_prm%msk_co2)
	  msk2 = bsn_prm%msk_co2 / (bsn_prm%msk_co1 + bsn_prm%msk_co2)
	  bsn_prm%msk_co1 = msk1
	  bsn_prm%msk_co2 = msk2
      xkm = ch_vel(jrch)%wid_btm * bsn_prm%msk_co1 + ch_vel(jrch)%stor_dis_1bf * bsn_prm%msk_co1

      !! Muskingum numerical stability -Jaehak Jeong, 2011
      !! Check numerical stability
      detmax = 2.* xkm * (1.- bsn_prm%msk_x)
      detmin = 2.* xkm * bsn_prm%msk_x

      !! Discretize time interval to meet the stability criterion
      if (det > detmax) then
        if (det / 2. <= detmax) then
          det = 12
          nn = 2
        elseif (det / 4. <= detmax) then
          det = 6
          nn = 4
        else
          det = 1
          nn = 24
        endif
      else
        det = 24
        nn = 1
      end if

      !! volume at start of day
      vol = sd_ch(jrch)%stor

      !! subdaily time step
      do ii = 1, time%step

        !! water entering reach during time step
        inflo = ob(icmd)%tsin(ii)

        !! update volume of water in reach
        vol = vol + inflo
        vol = Max(vol, 1.e-14)

        !! Find average flowrate in a subdaily time interval
        volrt = vol / (86400. / nn)

        !! Find maximum flow capacity of the channel at bank full
        c = ch_hyd(jhyd)%side
	    p = sd_ch_vel(jrch)%wid_btm + 2. * sd_ch(jrch)%chd * Sqrt(1. + c * c)
	    rh = sd_ch_vel(jrch)%area / p
	    maxrt = Qman(ch_vel(jrch)%area, rh, ch_hyd(jhyd)%n, sd_ch(jrch)%chs)

        sdti = 0.
	    rchdep = 0.
	    p = 0.
	    rh = 0.
	    vc = 0.

        !! If average flowrate is greater than than the channel capacity at bank full
        !! then simulate flood plain flow else simulate the regular channel flow
        if (volrt > maxrt) then
	      rcharea = sd_ch_vel(jrch)%area
	      rchdep = sd_ch(jrch)%chd
	      p = sd_ch_vel(jrch)%wid_btm + 2. * sd_ch(jrch)%chd * Sqrt(1. + c * c)
	      rh = sd_ch_vel(jrch)%area / p
	      sdti = maxrt
	      adddep = 0
	      !! find the crossectional area and depth for volrt by iteration method at 1cm interval depth
	      !! find the depth until the discharge rate is equal to volrt
	      Do While (sdti < volrt)
            adddep = adddep + 0.01
            addarea = rcharea + ((sd_ch(jrch)%chw * 5) + 4 * adddep) * adddep
            addp = p + (sd_ch(jrch)%chw * 4) + 2. * adddep * Sqrt(1. + 4 * 4)
	        rh = addarea / addp
            sdti = Qman(addarea, rh, ch_hyd(jhyd)%n, sd_ch(jrch)%chs)
	      end do
	      rcharea = addarea
	      rchdep = sd_ch(jrch)%chd + adddep
	      p = addp
	      sdti = volrt
          !! store floodplain water that can be used by riparian HRU"s [Ann van Griensven]
          ch(jrch)%chfloodvol = (volrt - maxrt)* 86400 * rt_delt
	    else
	      !! find the crossectional area and depth for volrt
	      !! by iteration method at 1cm interval depth
	      !! find the depth until the discharge rate is equal to volrt
	      Do While (sdti < volrt)
	        rchdep = rchdep + 0.01
	        rcharea = (sd_ch_vel(jrch)%wid_btm + c * rchdep) * rchdep
	        p = sd_ch_vel(jrch)%wid_btm + 2. * rchdep * Sqrt(1. + c * c)
	        rh = rcharea / p
	        sdti = Qman(rcharea, rh, ch_hyd(jhyd)%n, sd_ch(jrch)%chs)
	      end do
	      sdti = volrt
	    end if

        !! calculate top width of channel at water level
        if (rchdep <= sd_ch(jrch)%chd) then
          topw = sd_ch_vel(jrch)%wid_btm + 2. * rchdep * c
        else
          topw = 5 * sd_ch(jhyd)%chw + 2. *(rchdep - sd_ch(jrch)%chd) * 4.
        end if

        if (sdti > 0) then

        !! calculate velocity and travel time
        vc = sdti / rcharea
	    rttime = sd_ch(jrch)%chl * 1000. / (3600. * vc)

        !! Compute coefficients
        yy = 2. * xkm * (1. - bsn_prm%msk_x) + det
        c1 = (det - 2. * xkm * bsn_prm%msk_x) / yy
        c2 = (det + 2. * xkm * bsn_prm%msk_x) / yy
        c3 = (2. * xkm * (1. - bsn_prm%msk_x) - det) / yy
        c4 = 0.

   ! ***    outflo = c1 * wtrin + c2 * ch(jrch)%flwin + c3 * ch(jrch)%flwout
	    outflo = Min(outflo, (vol))

          ttime = Min(24., ttime)
          !! calculate transmission losses
          tl = sd_chd(jhyd)%chk * sd_ch(jrch)%chl * perim_wet * ttime   !mm/hr * km * mm * hr = m3
          tl = Min(tl, outflo)
          outflo = outflo - tl
          trans_loss = trans_loss + tl

          !! calculate evaporation
          if (outflo > 0.) then
            !! calculate width of channel at water level
            if (dep_flo <= sd_ch(jrch)%chd) then
              topw = sd_ch_vel(jrch)%wid_btm + 2. * dep_flo * sd_chd(jhyd)%chss
            else
              topw = 5. * sd_ch(jrch)%chw + 8. * (dep_flo - sd_ch(jrch)%chd)
            end if

            iwst = 1
            ev = bsn_prm%evrch * wst(iwst)%weat%pet * sd_ch(jrch)%chl * topw * ttime
            if (ev < 0.) ev = 0.
            ev = Min(ev, outflo)
            outflo = outflo - ev
            evap = evap + ev
          end if

          !! set volume of water in channel at end of hour
          vol = vol - outflo - tl - ev
          ob(icmd)%hyd_flo(1,ii) = outflo

        end if          !! rate_flo > 0.

      end do            !! end of sub-daily loop

      !! save storage volume for next day
      sd_ch(jrch)%stor = vol

      return
      end subroutine ch_rtmusk


! This code is from QEDMOD with minor modifications.
!
!   V.M. Shabaev, I.I. Tupitsyn, V.A. Yerokhin, QEDMOD: Fortran program for calculating
!   the model Lamb-shift operator, Computer Physics Communications, Volume 189, 2015,
!   Pages 175-181, ISSN 0010-4655, http://dx.doi.org/10.1016/j.cpc.2014.12.002.
!
! For a description of the changes made, see the README.
!
! Original code is distributed under the CPC non-profit use licence
! (http://cpc.cs.qub.ac.uk/licence/licence.html). Redistributed here as part of
! GRASP2K with permission from the authors.
!
! Originally from: f/potgen/grid.f
!
c       =================================================
        subroutine SHAB_grid_args(r1_arg, r2_arg)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       This subroutine initializes the semi-logarithmic
c       radial grid r(i), which is used for the calculation
c       of the wave functions and the numerical integrations.
c
c       The nonuniform grid r is obtained from the uniform grid rho
c       by using the change of variables
c       rho(r)=al*r+bt*ln(r),
c       where al and bt are the grid parameters.
c
c       rho(r) is the uninform grid,
c       rho_i=rho_1+h*(i-1), where h is the grid spacing.
c
c       ii   .... number of grid points (ii=maxii-20), where
c                 maxii is given in the include file
c                 'qedmod.inc'
c       r(i) .... non-unform radial grid (i=1,ii)
c       r1   .... the first grid point closest to the origin
c       r2   .... the last grid point (the size of the box), defined
c                 in the atom_data subroutine r2=r(ii).
c       h    .... Semi-logarithmic grid step
c       z    .... Nuclear charge
c       rnucl ... Radius of the nuclear sphere
c       knucl  ..... Nuclear model (0 - point, 1 - Fermi model,
c                    2 - uniform sphere)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        implicit real*8 (a-h,o-z)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        include 'qedmod.inc'
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        common /SHAB_const/cl,z
        common /SHAB_grd/h,r1,r2,al,bt,ii
        common /SHAB_ncls/knucl,inucl,rnucl
        common /SHAB_pots/v(maxii),unuc(maxii),uehl(maxii),v_wk(maxii),
     &  vloc(maxii),vsemi_loc(maxii,6),wsemi_loc(maxii,6),ww(maxii)
        common /SHAB_ry/y(maxii),r(maxii)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        r1=r1_arg
        r2=r2_arg
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        rmax=dabs(r2)
        imax=maxii-20
        imax=((imax+1)/2)*2-1
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       Semi-logarithmic grid: ro=al*r+bt*ln(r)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        ii=imax
        bt=1.d0
        h=bt*dlog(r2/r1)/((ii-1)*0.67)
        al=(h*(imax-1)-bt*dlog(r2/r1))/(r2-r1)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        if (al.ge.0.d0) goto 210
        ii=(bt*dlog(r2/r1))/h+1
        write( *,99) imax,ii,h,al,bt,r1,r2
99      format(/'  ii > Imax'/'  Imax=',i6/'  ii  =',i6/
     1  '  h   =',f9.4,/'  al  =',f9.3/,'  bt  =',f9.3/
     2  '  r1  =',e10.3,'  r2  =',f9.3)
        call SHAB_exit1
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       Correction for the Sphere nuclear model
c       r(inucl)=rnucl
c       - - - - - - - - - - - - - - - - - - - - - - - - -
210     inucl=0
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        if (knucl.eq.2) then
          ro1=al*r1+bt*dlog(r1)
          ron=al*rnucl+bt*dlog(rnucl)
          d=ron-ro1
          inucl=(d/h+0.0001d0)+1
          if (inucl.lt.11) then
            inucl=11
            dr=d-(inucl-1)*h
            ro1=ro1+dr
            r0=dexp(ro1)/bt
            r1=SHAB_rr(ro1,r0)
          endif
          dr=(rnucl-r1)/(r2-r1)
          h=(bt*dlog(rnucl/r1)-bt*dlog(r2/r1)*dr)/
     &    ((inucl-1)-(ii-1)*dr)
          al=((inucl-1)*h-bt*dlog(rnucl/r1))/(rnucl-r1)
        endif
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        do i=1,maxii
          r(i)=0.d0
          v(i)=0.d0
        enddo
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        call SHAB_tbr(ii,r1,h,al,bt,r,v)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        write( *,5) ii,r1,r2
        write(11,5) ii,r1,r2
5       format (/2x,'Semi-logarithmic radial grid:',
     1  /2x,'npoints    =',i6,/2x,'rmin    =',e13.4,
     2  /2x,'rmax    =',e13.4)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
1000    return
        end
c       =================================================
        subroutine SHAB_tbr(ii,r1,h,al,bt,r,v)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       Initialization of the Semi-logarithmic radial grid
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        implicit real*8 (a-h,o-z)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        dimension r(*),v(*)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        r(1)=r1
        d=r1
        t=al*d+bt
        v(1)=d/t
        p=al*d+bt*dlog(d)
        do 10 i=2,ii
        p=p+h
200     t=al*d+bt*dlog(d)
        t=(p-t)/(al*d+bt)
        d=d*(1.d0+t)
        if (dabs(t).gt.0.5d-11) goto 200
        t=al*d+bt
        v(i)=d/t
        r(i)=d
10      continue
        return
        end
c       =================================================
        function SHAB_rr(ro,r0)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       This subroutine solve the equation ro=al*r+bt*ln(r)
c       and define the value of r for the given ro.
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        implicit real*8 (a-h,o-z)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        common /SHAB_grd/h,r1,r2,al,bt,ii
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        r=r0
200     t=al*r+bt*dlog(r)
        t=(ro-t)/(al*r+bt)
        if (t.le.-1.d0) t=-0.5d0
        r=r*(1.d0+t)
        if (dabs(t).gt.0.1d-8) goto 200
        SHAB_rr=r
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        return
        end


C
C	$Id: cstrlist.f,v 1.5 2008-07-27 03:10:08 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSTRLIST (N,LIST,LPTR,LEND,NROW, NT,LTRI,IER)
      INTEGER N, LIST(*), LPTR(*), LEND(N), NROW, NT,
     .        LTRI(NROW,*), IER
C
C***********************************************************
C
C                                              From STRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/20/96
C
C   This subroutine converts a triangulation data structure
C from the linked list created by Subroutine CSTRMESH to a
C triangle list.
C
C On input:
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       LIST,LPTR,LEND = Linked list data structure defin-
C                        ing the triangulation.  Refer to
C                        Subroutine CSTRMESH.
C
C       NROW = Number of rows (entries per triangle) re-
C              served for the triangle list LTRI.  The value
C              must be 6 if only the vertex indexes and
C              neighboring triangle indexes are to be
C              stored, or 9 if arc indexes are also to be
C              assigned and stored.  Refer to LTRI.
C
C The above parameters are not altered by this routine.
C
C       LTRI = Integer array of length at least NROW*NT,
C              where NT is at most 2N-4.  (A sufficient
C              length is 12N if NROW=6 or 18N if NROW=9.)
C
C On output:
C
C       NT = Number of triangles in the triangulation unless
C            IER .NE. 0, in which case NT = 0.  NT = 2N-NB-2
C            if NB .GE. 3 or 2N-4 if NB = 0, where NB is the
C            number of boundary nodes.
C
C       LTRI = NROW by NT array whose J-th column contains
C              the vertex nodal indexes (first three rows),
C              neighboring triangle indexes (second three
C              rows), and, if NROW = 9, arc indexes (last
C              three rows) associated with triangle J for
C              J = 1,...,NT.  The vertices are ordered
C              counterclockwise with the first vertex taken
C              to be the one with smallest index.  Thus,
C              LTRI(2,J) and LTRI(3,J) are larger than
C              LTRI(1,J) and index adjacent neighbors of
C              node LTRI(1,J).  For I = 1,2,3, LTRI(I+3,J)
C              and LTRI(I+6,J) index the triangle and arc,
C              respectively, which are opposite (not shared
C              by) node LTRI(I,J), with LTRI(I+3,J) = 0 if
C              LTRI(I+6,J) indexes a boundary arc.  Vertex
C              indexes range from 1 to N, triangle indexes
C              from 0 to NT, and, if included, arc indexes
C              from 1 to NA, where NA = 3N-NB-3 if NB .GE. 3
C              or 3N-6 if NB = 0.  The triangles are or-
C              dered on first (smallest) vertex indexes.
C
C       IER = Error indicator.
C             IER = 0 if no errors were encountered.
C             IER = 1 if N or NROW is outside its valid
C                     range on input.
C             IER = 2 if the triangulation data structure
C                     (LIST,LPTR,LEND) is invalid.  Note,
C                     however, that these arrays are not
C                     completely tested for validity.
C
C Modules required by CSTRLIST:  None
C
C Intrinsic function called by CSTRLIST:  ABS
C
C***********************************************************
C
      INTEGER I, I1, I2, I3, ISV, J, KA, KN, KT, LP, LP2,
     .        LPL, LPLN1, N1, N2, N3, NM2
      LOGICAL ARCS
C
C Local parameters:
C
C ARCS =     Logical variable with value TRUE iff are
C              indexes are to be stored
C I,J =      LTRI row indexes (1 to 3) associated with
C              triangles KT and KN, respectively
C I1,I2,I3 = Nodal indexes of triangle KN
C ISV =      Variable used to permute indexes I1,I2,I3
C KA =       Arc index and number of currently stored arcs
C KN =       Index of the triangle that shares arc I1-I2
C              with KT
C KT =       Triangle index and number of currently stored
C              triangles
C LP =       LIST pointer
C LP2 =      Pointer to N2 as a neighbor of N1
C LPL =      Pointer to the last neighbor of I1
C LPLN1 =    Pointer to the last neighbor of N1
C N1,N2,N3 = Nodal indexes of triangle KT
C NM2 =      N-2
C
C
C Test for invalid input parameters.
C
      IF (N .LT. 3  .OR.  (NROW .NE. 6  .AND.  NROW .NE. 9))
     .  GO TO 11
C
C Initialize parameters for loop on triangles KT = (N1,N2,
C   N3), where N1 < N2 and N1 < N3.
C
C   ARCS = TRUE iff arc indexes are to be stored.
C   KA,KT = Numbers of currently stored arcs and triangles.
C   NM2 = Upper bound on candidates for N1.
C
      ARCS = NROW .EQ. 9
      KA = 0
      KT = 0
      NM2 = N-2
C
C Loop on nodes N1.
C
      DO 9 N1 = 1,NM2
C
C Loop on pairs of adjacent neighbors (N2,N3).  LPLN1 points
C   to the last neighbor of N1, and LP2 points to N2.
C
        LPLN1 = LEND(N1)
        LP2 = LPLN1
    1     LP2 = LPTR(LP2)
          N2 = LIST(LP2)
          LP = LPTR(LP2)
          N3 = ABS(LIST(LP))
          IF (N2 .LT. N1  .OR.  N3 .LT. N1) GO TO 8
C
C Add a new triangle KT = (N1,N2,N3).
C
          KT = KT + 1
          LTRI(1,KT) = N1
          LTRI(2,KT) = N2
          LTRI(3,KT) = N3
C
C Loop on triangle sides (I2,I1) with neighboring triangles
C   KN = (I1,I2,I3).
C
          DO 7 I = 1,3
            IF (I .EQ. 1) THEN
              I1 = N3
              I2 = N2
            ELSEIF (I .EQ. 2) THEN
              I1 = N1
              I2 = N3
            ELSE
              I1 = N2
              I2 = N1
            ENDIF
C
C Set I3 to the neighbor of I1 that follows I2 unless
C   I2->I1 is a boundary arc.
C
            LPL = LEND(I1)
            LP = LPTR(LPL)
    2       IF (LIST(LP) .EQ. I2) GO TO 3
              LP = LPTR(LP)
              IF (LP .NE. LPL) GO TO 2
C
C   I2 is the last neighbor of I1 unless the data structure
C     is invalid.  Bypass the search for a neighboring
C     triangle if I2->I1 is a boundary arc.
C
            IF (ABS(LIST(LP)) .NE. I2) GO TO 12
            KN = 0
            IF (LIST(LP) .LT. 0) GO TO 6
C
C   I2->I1 is not a boundary arc, and LP points to I2 as
C     a neighbor of I1.
C
    3       LP = LPTR(LP)
            I3 = ABS(LIST(LP))
C
C Find J such that LTRI(J,KN) = I3 (not used if KN > KT),
C   and permute the vertex indexes of KN so that I1 is
C   smallest.
C
            IF (I1 .LT. I2  .AND.  I1 .LT. I3) THEN
              J = 3
            ELSEIF (I2 .LT. I3) THEN
              J = 2
              ISV = I1
              I1 = I2
              I2 = I3
              I3 = ISV
            ELSE
              J = 1
              ISV = I1
              I1 = I3
              I3 = I2
              I2 = ISV
            ENDIF
C
C Test for KN > KT (triangle index not yet assigned).
C
            IF (I1 .GT. N1) GO TO 7
C
C Find KN, if it exists, by searching the triangle list in
C   reverse order.
C
            DO 4 KN = KT-1,1,-1
              IF (LTRI(1,KN) .EQ. I1  .AND.  LTRI(2,KN) .EQ.
     .            I2  .AND.  LTRI(3,KN) .EQ. I3) GO TO 5
    4         CONTINUE
            GO TO 7
C
C Store KT as a neighbor of KN.
C
    5       LTRI(J+3,KN) = KT
C
C Store KN as a neighbor of KT, and add a new arc KA.
C
    6       LTRI(I+3,KT) = KN
            IF (ARCS) THEN
              KA = KA + 1
              LTRI(I+6,KT) = KA
              IF (KN .NE. 0) LTRI(J+6,KN) = KA
            ENDIF
    7       CONTINUE
C
C Bottom of loop on triangles.
C
    8     IF (LP2 .NE. LPLN1) GO TO 1
    9     CONTINUE
C
C No errors encountered.
C
      NT = KT
      IER = 0
      RETURN
C
C Invalid input parameter.
C
   11 NT = 0
      IER = 1
      RETURN
C
C Invalid triangulation data structure:  I1 is a neighbor of
C   I2, but I2 is not a neighbor of I1.
C
   12 NT = 0
      IER = 2
      RETURN
      END


function isfinite(A) result(flag)
complex(kind=8), intent(in) :: A(:)
logical :: flag
real(kind=8), parameter :: INF = huge(1.d0)
real(kind=8) :: Ar,Ai
integer :: i,n

flag = .true.
n = size(A)
do i=1,n
    Ar = real(A(i))
    Ai = aimag(A(i))
    if((.not.(abs(Ar) < INF .and. abs(Ai) < INF)) .and. (isnan(Ar) .or. isnan(Ai))) then
        flag = .false.
        exit
    endif
enddo
end function isfinite


      subroutine setprob()
      implicit none

      double precision pi, pi2
      common /compi/ pi,pi2

      double precision uvel, vvel
      common /comvelocity/ uvel, vvel

      open(10,file='setprob.data')
      read(10,*) uvel
      read(10,*) vvel
      close(10)

      pi = 4.d0*datan(1.d0)
      pi2 = 2.d0*pi

      end


! cellular automata (from adaptor/simple/ca.hpf)
      program automata

! n = size of automata
! m = number of iterations
      integer n, m, i, j
      parameter (n=70,m=40)

      logical field(0:n+1,3)
!hpf$ processors p(2)
!hpf$ distribute field(block,*) onto p

      character s(n)
!hpf$ align with field(i,*):: s(i)

! initialize
!hpf$ independent
      do i=1, n
         field(i,1)=.false.
      enddo
!fcd$ local
      field(n/2, 1)=.true.
!fcd$ end local

      do j=1, m

! I must model the Circular SHIFTs...
!fcd$    local
            field(0,1)=field(n,1)
!fcd$    end local
!fcd$    local
            field(n+1,1)=field(1,1)
!fcd$    end local
!hpf$    independent
         do i=1, n
            field(i,2)=field(i-1,1)
            field(i,3)=field(i+1,1)
         enddo

! now compute new value
!hpf$    independent
         do i=1, n
            field(i,1)=field(i,2).neqv.field(i,3)
         enddo

! compose and print out the result
!hpf$    independent
         do i=1, n
            if (field(i,1)) then
               s(i)= ' '
            else
               s(i)= '*'
            endif
         enddo

         print *, s

      enddo

      end


! Advent of Code 2021 : https://adventofcode.com/2021
! Puzzle for Day 02 part 01 :
! Build with:  gfortran -static-libgcc -o aoc_day02_p1 aoc_day02_p1.f90

program aoc_day02_p1

	use, intrinsic :: iso_fortran_env
	implicit none

	! Declare and set constants the AOC day and part
	integer,parameter :: day = 2, part = 1

	! AOC answer
	integer :: total_pos = 0

	! Declare file related variables
	character(len=*), parameter :: filename = "day02-input.txt"
	character(len=*), parameter :: error1 = "file: '"//''//filename//''//"' not found"

	! Output startup message
	call display_welcome(day,part)

	if (.NOT. file_exists(filename)) stop error1

	total_pos = get_movement_totals(filename)

	! Display the solution summary
	write(*,'(A,I8.8)') " » ANSWER: Final horizontal position multiplied by final depth: ",total_pos

contains

	! Display the AoC puzzle day and part being resolved
	subroutine display_welcome(day,part)
		implicit none
		integer, intent(in) :: day,part
		write (*,'(A,I2.2,A,I2.2)') "AoC 2021 - solution for Day ",day," part ",part
	end subroutine display_welcome

	! Check input filename exists
	function file_exists(filename) result (exists)
		implicit none
		character(len=*), intent(in) :: filename
		logical :: exists ! type for the return.  NB: no intent(out) needed.

		inquire(file=filename, exist=exists)
	end function file_exists

	! Solve the problem : total number of depth increases for each sonar reading
	function get_movement_totals(filename) result (total_pos)
		implicit none
		character(len=*), intent(in) :: filename
		integer :: fileunit,io,io_err,X,total_for=0,total_up=0,total_down=0,final_depth=0
		character(len=10) :: data_in
		integer :: total_pos ! type for the returned answer

		open(newunit=fileunit, file=filename, action='read', position='rewind')

		do
			read(fileunit,*,iostat=io_err) data_in,X
			if(io_err .NE. 0) exit

			select case (trim(data_in))
			case ("forward")
				total_for = total_for + X
			case ("up")
				total_up = total_up + X
			case ("down")
				total_down = total_down + X
			end select
		end do

		close(fileunit)

		final_depth = total_down - total_up

		write (*,'(A)') "Calculating submarine movement:"
		write (*,'(A,I4.4)') " » Total forward: ",total_for
		write (*,'(A,I4.4)') " » Total up: ",total_up
		write (*,'(A,I4.4)') " » Total down: ",total_down
		write (*,'(A,I4.4)') " » Final depth: ",final_depth

		total_pos = final_depth * total_for

	end function get_movement_totals

end program aoc_day02_p1


PROGRAM MAIN

  USE omp_lib

  ! Size of grid and number of iterations
  INTEGER, PARAMETER :: N = 10000, T =10
  LOGICAL, DIMENSION(:,:), ALLOCATABLE :: grid, tmp_grid
  INTEGER, DIMENSION(2) :: init_pos
  INTEGER :: it, ix, iy
  INTEGER :: cnt
  LOGICAL :: show = .FALSE.

  ALLOCATE(grid(N,N), tmp_grid(N,N))

  grid = .FALSE.

  !Place a simple structure in the bottom left - this should move
  ! and reform it's shape (called a glider)
  init_pos = [2, N-2]
  grid(init_pos(1)+1:init_pos(1)+3, init_pos(2)) = .TRUE.
  grid(init_pos(1)+3, init_pos(2)+1) = .TRUE.
  grid(init_pos(1)+2, init_pos(2)+2) = .TRUE.

  !Iterate over time
  DO it = 1, T

    ! Loop over grid
    ! Use a temporary for the updated state
    ! Reset this each time
    tmp_grid = .FALSE.
    ! Leave all edge cells unchanged
!$OMP PARALLEL DO PRIVATE(cnt)
   DO ix = 2, N-1
     DO iy = 2, N-1
        ! We need to know how many True neghbours the current location has
        ! The cell itself isn't included in the sum
        cnt = COUNT(grid(ix-1:ix+1, iy-1:iy+1))
        IF(grid(ix, iy)) cnt = cnt -1
        ! The automaton rules can be reduced to this simple condition
        IF((cnt == 2 .AND. grid(ix,iy)) .OR. cnt == 3) tmp_grid(ix, iy) = .TRUE.

      END DO
    END DO
!$OMP END PARALLEL DO
!$OMP WORKSHARE
    grid = tmp_grid
!$OMP END WORKSHARE
  END DO

 IF(show) THEN
    ! Show to screen
    PRINT*, "_________________________________"
    PRINT*, "Time =", it-1
    PRINT*, "_________________________________"
    DO iy = 1, N
      PRINT*, MERGE("*", " ", grid(:,iy))

    END DO
    PRINT*, "_________________________________"
  END IF

END PROGRAM


! Copyright 2016-2021 Free Software Foundation, Inc.
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! This file is the Fortran source file for derived-type-function.exp.
! It was contributed by Walfred Tedeschi (walfred.tedeschi@intel.com).

module class_Rectangle
  implicit none
  private

  type, public :: Rectangle
     real :: a
     real :: b
   contains
     procedure :: area => rectangle_area
     procedure :: print_area => print_area
  end type Rectangle
contains

  function rectangle_area (this) result (area)
    class (Rectangle), intent (in) :: this

    real :: area
    area = this%a * this%b
  end function rectangle_area

  subroutine print_area (this)
    class (Rectangle), intent (in) :: this
    real :: area

    area = this%area ()
    print *, ' area = ', area
  end subroutine print_area

end module class_Rectangle

program rectangle_Test
  use class_Rectangle
  implicit none

  type (Rectangle) :: aRec
  real areaE

  aRec = Rectangle (2., 3.)
  ! bp
  call aRec%print_area

end program rectangle_Test


! { dg-do run }
! { dg-options -fno-range-check }
! PR38504 double minus sign when printing integer
! Test case derived from example by Jos de Kloe
program IntAdtest

  integer, parameter :: i8_ = Selected_Int_Kind(18)  ! = integer*8
  character(len=22) :: str_value
  integer(i8_) :: value
  character(len=*), parameter :: format_IntAd  = "(i22)"

  value = -9223372036854775807_i8_ -1
  write(str_value, format_IntAd) value
  if (str_value.ne."  -9223372036854775808") call abort

end program IntAdtest


C
C	$Id: conxch.f,v 1.5 2008-07-27 00:16:57 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      INTEGER FUNCTION CONXCH (X,Y,I1,I2,I3,I4)
C
C THIS FUNCTION DETERMINES WHETHER OR NOT THE EXCHANGE OF TWO
C TRIANGLES IS NECESSARY ON THE BASIS OF MAX-MIN-ANGLE CRITERION
C BY C. L. LAWSON.
C THE INPUT PARAMETERS ARE
C     X,Y = ARRAYS CONTAINING THE COORDINATES OF THE DATA
C           POINTS,
C     I1,I2,I3,I4 = POINT NUMBERS OF FOUR POINTS P1, P2,
C                   P3, AND P4 THAT FORM A QUADRILATERAL
C                   WITH P3 AND P4 CONNECTED DIADONALLY.
C THIS FUNCTION RETURNS A VALUE 1 (ONE) WHEN AN EXCHANGE IS
C NEEDED, AND 0 (ZERO) OTHERWISE.
C DECLARATION STATEMENTS
C
      DIMENSION       X(1)       ,Y(1)
      DIMENSION       X0(4)      ,Y0(4)
      EQUIVALENCE     (C2SQ,C1SQ),(A3SQ,B2SQ),(B3SQ,A1SQ),(A4SQ,B1SQ),
     1                (B4SQ,A2SQ),(C4SQ,C3SQ)
C
        SAVE
C
C STATEMENT FUNCTIONS
C
C CALCULATION
C
      X0(1) = X(I1)
      Y0(1) = Y(I1)
      X0(2) = X(I2)
      Y0(2) = Y(I2)
      X0(3) = X(I3)
      Y0(3) = Y(I3)
      X0(4) = X(I4)
      Y0(4) = Y(I4)
      IDX = 0
      U3 = (Y0(2)-Y0(3))*(X0(1)-X0(3))-(X0(2)-X0(3))*(Y0(1)-Y0(3))
      U4 = (Y0(1)-Y0(4))*(X0(2)-X0(4))-(X0(1)-X0(4))*(Y0(2)-Y0(4))
      IF (U3*U4 .LE. 0.0) GO TO  100
      U1 = (Y0(3)-Y0(1))*(X0(4)-X0(1))-(X0(3)-X0(1))*(Y0(4)-Y0(1))
      U2 = (Y0(4)-Y0(2))*(X0(3)-X0(2))-(X0(4)-X0(2))*(Y0(3)-Y0(2))
      A1SQ = (X0(1)-X0(3))**2+(Y0(1)-Y0(3))**2
      B1SQ = (X0(4)-X0(1))**2+(Y0(4)-Y0(1))**2
      C1SQ = (X0(3)-X0(4))**2+(Y0(3)-Y0(4))**2
      A2SQ = (X0(2)-X0(4))**2+(Y0(2)-Y0(4))**2
      B2SQ = (X0(3)-X0(2))**2+(Y0(3)-Y0(2))**2
      C3SQ = (X0(2)-X0(1))**2+(Y0(2)-Y0(1))**2
      S1SQ = U1*U1/(C1SQ*MAX(A1SQ,B1SQ))
      S2SQ = U2*U2/(C2SQ*MAX(A2SQ,B2SQ))
      S3SQ = U3*U3/(C3SQ*MAX(A3SQ,B3SQ))
      S4SQ = U4*U4/(C4SQ*MAX(A4SQ,B4SQ))
      IF (MIN(S1SQ,S2SQ) .LT. MIN(S3SQ,S4SQ)) IDX = 1
  100 CONXCH = IDX
      RETURN
C
      END