!
!...Subroutine: Get eigenvalues and eigenvectors for 2x2 symmetric matrix
!
subroutine getEigensystem(matinp, eigenvect, eigenvalue,ielem)
use constant
implicit none
real*8, dimension(ndimn, ndimn), intent(in)::matinp
real*8, dimension(ndimn, ndimn), intent(out)::eigenvect
real*8, dimension(ndimn),        intent(out)::eigenvalue
integer,                          intent(in)::ielem
!
!...Local real
real*8:: a,b,c,d
real*8:: lamda1,lamda2
real*8:: matz, matt,matc,mats
real*8:: eps
!
eps = 1.d-6
!
a = matinp(1, 1)
b = matinp(1, 2)
c = matinp(2, 1)
d = matinp(2, 2)

if(b.eq.0)then
!
lamda1 = a
lamda2 = d
!
matc = 1.d0
mats = 0.d0
!

else
!
matz = (d-a)/(2.d0*b)

if(abs(matz).lt.6.d7)then
matt = sign(1.d0/(abs(matz)+sqrt(1.d0+matz**2)) ,matz)
else
matt = sign(0.5d0/abs(matz), matz)
endif
!
matc = sqrt(1.d0/(1.d0+matt**2))
mats = matc*matt
!
!if(ielem.eq.2.or.ielem.eq.31)then
!print*,'ielem eigenvalue2',ielem,lamda1,lamda2,matz,matt,b
!endif
!
matt = matt*b
!
lamda1 = a - matt
lamda2 = d + matt
!
endif
!
!
!...Part II: Specify eigenvalues and eigenvectors in order
!
if(lamda1.le.lamda2)then
!
eigenvalue(1) = lamda1
eigenvalue(2) = lamda2
!
eigenvect(1,1) = matc
eigenvect(1,2) =-mats

eigenvect(2,1) = mats
eigenvect(2,2) = matc

else
!
eigenvalue(1) = lamda2
eigenvalue(2) = lamda1
!
eigenvect(1,1) = mats
eigenvect(1,2) = matc

eigenvect(2,1) = matc
eigenvect(2,2) =-mats

endif

end subroutine getEigensystem
!
!...Symmetric matrix
!
subroutine matrix_sym(ni, nj, nq, mtlhs, rhs, mtsym, rhssym)
!
implicit none
!
integer*4, intent(in)::ni, nj, nq
real*8, dimension(ni,nj), intent(in):: mtlhs
real*8, dimension(nq,ni),    intent(in):: rhs
real*8, dimension(nj,nj), intent(out):: mtsym
real*8, dimension(nq,nj),   intent(out):: rhssym

!...Local

integer:: im, jm,km, iq

!...Zero out
mtsym  = 0.d0
rhssym = 0.d0

!...Symmetry matrix
do im = 1, nj
do jm = 1, nj
do km = 1, ni
mtsym(im, jm) = mtsym(im, jm) + mtlhs(km, im)*mtlhs(km, jm)
enddo
enddo
enddo

!...Symmetry rhs
do iq = 1 ,nq
do im = 1, nj
do km = 1, ni
rhssym(iq, im) = rhssym(iq, im) + mtlhs(km, im)*rhs(iq, km)
enddo
enddo
enddo

return
end subroutine matrix_sym
!
!...Subroutine: Get inverse small matrix for n=2,,,5....
!
subroutine Matinv225(a,b,n)

implicit none
integer, intent(in):: n
real*8, intent(in)::  a(n,n)
real*8, intent(out):: b(n,n)
real*8:: bt(n,n)
real*8 det
real*8::a11, a12, a13, a14, a15, a21, a22, a23, a24, &
a25, a31, a32, a33, a34, a35, a41, a42, a43, a44, a45,   &
a51, a52, a53, a54, a55
integer::i

! step 0: initialization for matrices L and U and b
! Fortran 90/95 aloows such operations on matrices
if(n.eq.2)then
det = a(1, 1)*a(2, 2)-a(1, 2)*a(2, 1)

b(1, 1) = a(2, 2)
b(1, 2) =-a(1, 2)
b(2, 1) =-a(2, 1)
b(2, 2) = a(1, 1)
elseif(n.eq.3)then
!
det   = a(1,1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2)) &
-a(1,2)*(a(2,1)*a(3,3)-a(2,3)*a(3,1)) &
+a(1,3)*(a(2,1)*a(3,2)-a(2,2)*a(3,1))
!
b(1,1) =  a(2,2)*a(3,3) - a(2,3)*a(3,2)
b(2,1) =  a(2,3)*a(3,1) - a(2,1)*a(3,3)
b(3,1) =  a(2,1)*a(3,2) - a(2,2)*a(3,1)

b(1,2) =  a(1,3)*a(3,2) - a(1,2)*a(3,3)
b(2,2) =  a(1,1)*a(3,3) - a(1,3)*a(3,1)
b(3,2) =  a(1,2)*a(3,1) - a(1,1)*a(3,2)

b(1,3) =  a(1,2)*a(2,3) - a(1,3)*a(2,2)
b(2,3) =  a(1,3)*a(2,1) - a(1,1)*a(2,3)
b(3,3) =  a(1,1)*a(2,2) - a(1,2)*a(2,1)

elseif(n.eq.4)then
!
det  =  a(1,1)*(a(2,2)*(a(3,3)*a(4,4)-a(3,4)*a(4,3))  &
-a(2,3)*(a(3,2)*a(4,4)-a(3,4)*a(4,2))  &
+a(2,4)*(a(3,2)*a(4,3)-a(3,3)*a(4,2))) &
-a(1,2)*(a(2,1)*(a(3,3)*a(4,4)-a(3,4)*a(4,3))  &
-a(2,3)*(a(3,1)*a(4,4)-a(3,4)*a(4,1))  &
+a(2,4)*(a(3,1)*a(4,3)-a(3,3)*a(4,1))) &
+a(1,3)*(a(2,1)*(a(3,2)*a(4,4)-a(3,4)*a(4,2))  &
-a(2,2)*(a(3,1)*a(4,4)-a(3,4)*a(4,1))  &
+a(2,4)*(a(3,1)*a(4,2)-a(3,2)*a(4,1))) &
-a(1,4)*(a(2,1)*(a(3,2)*a(4,3)-a(3,3)*a(4,2))  &
-a(2,2)*(a(3,1)*a(4,3)-a(3,3)*a(4,1))  &
+a(2,3)*(a(3,1)*a(4,2)-a(3,2)*a(4,1)))

b(1,1) =  a(2,2)*(a(3,3)*a(4,4)-a(3,4)*a(4,3))-a(2,3)*(a(3,2)*a(4,4)-a(3,4)*a(4,2))+a(2,4)*(a(3,2)*a(4,3)-a(3,3)*a(4,2))
b(2,1) = -a(2,1)*(a(3,3)*a(4,4)-a(3,4)*a(4,3))+a(2,3)*(a(3,1)*a(4,4)-a(3,4)*a(4,1))-a(2,4)*(a(3,1)*a(4,3)-a(3,3)*a(4,1))
b(3,1) =  a(2,1)*(a(3,2)*a(4,4)-a(3,4)*a(4,2))-a(2,2)*(a(3,1)*a(4,4)-a(3,4)*a(4,1))+a(2,4)*(a(3,1)*a(4,2)-a(3,2)*a(4,1))
b(4,1) = -a(2,1)*(a(3,2)*a(4,3)-a(3,3)*a(4,2))+a(2,2)*(a(3,1)*a(4,3)-a(3,3)*a(4,1))-a(2,3)*(a(3,1)*a(4,2)-a(3,2)*a(4,1))

b(1,2) = -a(1,2)*(a(3,3)*a(4,4)-a(3,4)*a(4,3))+a(1,3)*(a(3,2)*a(4,4)-a(3,4)*a(4,2))-a(1,4)*(a(3,2)*a(4,3)-a(3,3)*a(4,2))
b(2,2) =  a(1,1)*(a(3,3)*a(4,4)-a(3,4)*a(4,3))-a(1,3)*(a(3,1)*a(4,4)-a(3,4)*a(4,1))+a(1,4)*(a(3,1)*a(4,3)-a(3,3)*a(4,1))
b(3,2) = -a(1,1)*(a(3,2)*a(4,4)-a(3,4)*a(4,2))+a(1,2)*(a(3,1)*a(4,4)-a(3,4)*a(4,1))-a(1,4)*(a(3,1)*a(4,2)-a(3,2)*a(4,1))
b(4,2) =  a(1,1)*(a(3,2)*a(4,3)-a(3,3)*a(4,2))-a(1,2)*(a(3,1)*a(4,3)-a(3,3)*a(4,1))+a(1,3)*(a(3,1)*a(4,2)-a(3,2)*a(4,1))

b(1,3) =  a(1,2)*(a(2,3)*a(4,4)-a(2,4)*a(4,3))-a(1,3)*(a(2,2)*a(4,4)-a(2,4)*a(4,2))+a(1,4)*(a(2,2)*a(4,3)-a(2,3)*a(4,2))
b(2,3) = -a(1,1)*(a(2,3)*a(4,4)-a(2,4)*a(4,3))+a(1,3)*(a(2,1)*a(4,4)-a(2,4)*a(4,1))-a(1,4)*(a(2,1)*a(4,3)-a(2,3)*a(4,1))
b(3,3) =  a(1,1)*(a(2,2)*a(4,4)-a(2,4)*a(4,2))-a(1,2)*(a(2,1)*a(4,4)-a(2,4)*a(4,1))+a(1,4)*(a(2,1)*a(4,2)-a(2,2)*a(4,1))
b(4,3) = -a(1,1)*(a(2,2)*a(4,3)-a(2,3)*a(4,2))+a(1,2)*(a(2,1)*a(4,3)-a(2,3)*a(4,1))-a(1,3)*(a(2,1)*a(4,2)-a(2,2)*a(4,1))

b(1,4) = -a(1,2)*(a(2,3)*a(3,4)-a(2,4)*a(3,3))+a(1,3)*(a(2,2)*a(3,4)-a(2,4)*a(3,2))-a(1,4)*(a(2,2)*a(3,3)-a(2,3)*a(3,2))
b(2,4) =  a(1,1)*(a(2,3)*a(3,4)-a(2,4)*a(3,3))-a(1,3)*(a(2,1)*a(3,4)-a(2,4)*a(3,1))+a(1,4)*(a(2,1)*a(3,3)-a(2,3)*a(3,1))
b(3,4) = -a(1,1)*(a(2,2)*a(3,4)-a(2,4)*a(3,2))+a(1,2)*(a(2,1)*a(3,4)-a(2,4)*a(3,1))-a(1,4)*(a(2,1)*a(3,2)-a(2,2)*a(3,1))
b(4,4) =  a(1,1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2))-a(1,2)*(a(2,1)*a(3,3)-a(2,3)*a(3,1))+a(1,3)*(a(2,1)*a(3,2)-a(2,2)*a(3,1))
elseif(n.eq.5)then
a11=a(1,1); a12=a(1,2); a13=a(1,3); a14=a(1,4); a15=a(1,5)
a21=a(2,1); a22=a(2,2); a23=a(2,3); a24=a(2,4); a25=a(2,5)
a31=a(3,1); a32=a(3,2); a33=a(3,3); a34=a(3,4); a35=a(3,5)
a41=a(4,1); a42=a(4,2); a43=a(4,3); a44=a(4,4); a45=a(4,5)
a51=a(5,1); a52=a(5,2); a53=a(5,3); a54=a(5,4); a55=a(5,5)

det = a15*a24*a33*a42*a51-a14*a25*a33*a42*a51-a15*a23*a34*a42*a51+    &
a13*a25*a34*a42*a51+a14*a23*a35*a42*a51-a13*a24*a35*a42*a51-       &
a15*a24*a32*a43*a51+a14*a25*a32*a43*a51+a15*a22*a34*a43*a51-       &
a12*a25*a34*a43*a51-a14*a22*a35*a43*a51+a12*a24*a35*a43*a51+       &
a15*a23*a32*a44*a51-a13*a25*a32*a44*a51-a15*a22*a33*a44*a51+       &
a12*a25*a33*a44*a51+a13*a22*a35*a44*a51-a12*a23*a35*a44*a51-       &
a14*a23*a32*a45*a51+a13*a24*a32*a45*a51+a14*a22*a33*a45*a51-       &
a12*a24*a33*a45*a51-a13*a22*a34*a45*a51+a12*a23*a34*a45*a51-       &
a15*a24*a33*a41*a52+a14*a25*a33*a41*a52+a15*a23*a34*a41*a52-       &
a13*a25*a34*a41*a52-a14*a23*a35*a41*a52+a13*a24*a35*a41*a52+       &
a15*a24*a31*a43*a52-a14*a25*a31*a43*a52-a15*a21*a34*a43*a52+       &
a11*a25*a34*a43*a52+a14*a21*a35*a43*a52-a11*a24*a35*a43*a52-       &
a15*a23*a31*a44*a52+a13*a25*a31*a44*a52+a15*a21*a33*a44*a52-       &
a11*a25*a33*a44*a52-a13*a21*a35*a44*a52+a11*a23*a35*a44*a52+       &
a14*a23*a31*a45*a52-a13*a24*a31*a45*a52-a14*a21*a33*a45*a52+       &
a11*a24*a33*a45*a52+a13*a21*a34*a45*a52-a11*a23*a34*a45*a52+       &
a15*a24*a32*a41*a53-a14*a25*a32*a41*a53-a15*a22*a34*a41*a53+       &
a12*a25*a34*a41*a53+a14*a22*a35*a41*a53-a12*a24*a35*a41*a53-       &
a15*a24*a31*a42*a53+a14*a25*a31*a42*a53+a15*a21*a34*a42*a53-       &
a11*a25*a34*a42*a53-a14*a21*a35*a42*a53+a11*a24*a35*a42*a53+       &
a15*a22*a31*a44*a53-a12*a25*a31*a44*a53-a15*a21*a32*a44*a53+       &
a11*a25*a32*a44*a53+a12*a21*a35*a44*a53-a11*a22*a35*a44*a53-       &
a14*a22*a31*a45*a53+a12*a24*a31*a45*a53+a14*a21*a32*a45*a53-       &
a11*a24*a32*a45*a53-a12*a21*a34*a45*a53+a11*a22*a34*a45*a53-       &
a15*a23*a32*a41*a54+a13*a25*a32*a41*a54+a15*a22*a33*a41*a54-       &
a12*a25*a33*a41*a54-a13*a22*a35*a41*a54+a12*a23*a35*a41*a54+       &
a15*a23*a31*a42*a54-a13*a25*a31*a42*a54-a15*a21*a33*a42*a54+       &
a11*a25*a33*a42*a54+a13*a21*a35*a42*a54-a11*a23*a35*a42*a54-       &
a15*a22*a31*a43*a54+a12*a25*a31*a43*a54+a15*a21*a32*a43*a54-       &
a11*a25*a32*a43*a54-a12*a21*a35*a43*a54+a11*a22*a35*a43*a54+       &
a13*a22*a31*a45*a54-a12*a23*a31*a45*a54-a13*a21*a32*a45*a54+       &
a11*a23*a32*a45*a54+a12*a21*a33*a45*a54-a11*a22*a33*a45*a54+       &
a14*a23*a32*a41*a55-a13*a24*a32*a41*a55-a14*a22*a33*a41*a55+       &
a12*a24*a33*a41*a55+a13*a22*a34*a41*a55-a12*a23*a34*a41*a55-       &
a14*a23*a31*a42*a55+a13*a24*a31*a42*a55+a14*a21*a33*a42*a55-       &
a11*a24*a33*a42*a55-a13*a21*a34*a42*a55+a11*a23*a34*a42*a55+       &
a14*a22*a31*a43*a55-a12*a24*a31*a43*a55-a14*a21*a32*a43*a55+       &
a11*a24*a32*a43*a55+a12*a21*a34*a43*a55-a11*a22*a34*a43*a55-       &
a13*a22*a31*a44*a55+a12*a23*a31*a44*a55+a13*a21*a32*a44*a55-       &
a11*a23*a32*a44*a55-a12*a21*a33*a44*a55+a11*a22*a33*a44*a55

b(1,1) = a25*a34*a43*a52-a24*a35*a43*a52-a25*a33*a44*a52+      &
a23*a35*a44*a52+a24*a33*a45*a52-a23*a34*a45*a52-a25*a34*a42*a53+   &
a24*a35*a42*a53+a25*a32*a44*a53-a22*a35*a44*a53-a24*a32*a45*a53+   &
a22*a34*a45*a53+a25*a33*a42*a54-a23*a35*a42*a54-a25*a32*a43*a54+   &
a22*a35*a43*a54+a23*a32*a45*a54-a22*a33*a45*a54-a24*a33*a42*a55+   &
a23*a34*a42*a55+a24*a32*a43*a55-a22*a34*a43*a55-a23*a32*a44*a55+   &
a22*a33*a44*a55

b(2,1) = -a15*a34*a43*a52+a14*a35*a43*a52+a15*a33*a44*a52-     &
a13*a35*a44*a52-a14*a33*a45*a52+a13*a34*a45*a52+a15*a34*a42*a53-   &
a14*a35*a42*a53-a15*a32*a44*a53+a12*a35*a44*a53+a14*a32*a45*a53-   &
a12*a34*a45*a53-a15*a33*a42*a54+a13*a35*a42*a54+a15*a32*a43*a54-   &
a12*a35*a43*a54-a13*a32*a45*a54+a12*a33*a45*a54+a14*a33*a42*a55-   &
a13*a34*a42*a55-a14*a32*a43*a55+a12*a34*a43*a55+a13*a32*a44*a55-   &
a12*a33*a44*a55

b(3,1) = a15*a24*a43*a52-a14*a25*a43*a52-a15*a23*a44*a52+      &
a13*a25*a44*a52+a14*a23*a45*a52-a13*a24*a45*a52-a15*a24*a42*a53+   &
a14*a25*a42*a53+a15*a22*a44*a53-a12*a25*a44*a53-a14*a22*a45*a53+   &
a12*a24*a45*a53+a15*a23*a42*a54-a13*a25*a42*a54-a15*a22*a43*a54+   &
a12*a25*a43*a54+a13*a22*a45*a54-a12*a23*a45*a54-a14*a23*a42*a55+   &
a13*a24*a42*a55+a14*a22*a43*a55-a12*a24*a43*a55-a13*a22*a44*a55+   &
a12*a23*a44*a55

b(4,1) = -a15*a24*a33*a52+a14*a25*a33*a52+a15*a23*a34*a52-     &
a13*a25*a34*a52-a14*a23*a35*a52+a13*a24*a35*a52+a15*a24*a32*a53-   &
a14*a25*a32*a53-a15*a22*a34*a53+a12*a25*a34*a53+a14*a22*a35*a53-   &
a12*a24*a35*a53-a15*a23*a32*a54+a13*a25*a32*a54+a15*a22*a33*a54-   &
a12*a25*a33*a54-a13*a22*a35*a54+a12*a23*a35*a54+a14*a23*a32*a55-   &
a13*a24*a32*a55-a14*a22*a33*a55+a12*a24*a33*a55+a13*a22*a34*a55-   &
a12*a23*a34*a55

b(5,1) = a15*a24*a33*a42-a14*a25*a33*a42-a15*a23*a34*a42+      &
a13*a25*a34*a42+a14*a23*a35*a42-a13*a24*a35*a42-a15*a24*a32*a43+   &
a14*a25*a32*a43+a15*a22*a34*a43-a12*a25*a34*a43-a14*a22*a35*a43+   &
a12*a24*a35*a43+a15*a23*a32*a44-a13*a25*a32*a44-a15*a22*a33*a44+   &
a12*a25*a33*a44+a13*a22*a35*a44-a12*a23*a35*a44-a14*a23*a32*a45+   &
a13*a24*a32*a45+a14*a22*a33*a45-a12*a24*a33*a45-a13*a22*a34*a45+   &
a12*a23*a34*a45

b(1,2) = -a25*a34*a43*a51+a24*a35*a43*a51+a25*a33*a44*a51-     &
a23*a35*a44*a51-a24*a33*a45*a51+a23*a34*a45*a51+a25*a34*a41*a53-   &
a24*a35*a41*a53-a25*a31*a44*a53+a21*a35*a44*a53+a24*a31*a45*a53-   &
a21*a34*a45*a53-a25*a33*a41*a54+a23*a35*a41*a54+a25*a31*a43*a54-   &
a21*a35*a43*a54-a23*a31*a45*a54+a21*a33*a45*a54+a24*a33*a41*a55-   &
a23*a34*a41*a55-a24*a31*a43*a55+a21*a34*a43*a55+a23*a31*a44*a55-   &
a21*a33*a44*a55

b(2,2) = a15*a34*a43*a51-a14*a35*a43*a51-a15*a33*a44*a51+      &
a13*a35*a44*a51+a14*a33*a45*a51-a13*a34*a45*a51-a15*a34*a41*a53+   &
a14*a35*a41*a53+a15*a31*a44*a53-a11*a35*a44*a53-a14*a31*a45*a53+   &
a11*a34*a45*a53+a15*a33*a41*a54-a13*a35*a41*a54-a15*a31*a43*a54+   &
a11*a35*a43*a54+a13*a31*a45*a54-a11*a33*a45*a54-a14*a33*a41*a55+   &
a13*a34*a41*a55+a14*a31*a43*a55-a11*a34*a43*a55-a13*a31*a44*a55+   &
a11*a33*a44*a55

b(3,2) = -a15*a24*a43*a51+a14*a25*a43*a51+a15*a23*a44*a51-     &
a13*a25*a44*a51-a14*a23*a45*a51+a13*a24*a45*a51+a15*a24*a41*a53-   &
a14*a25*a41*a53-a15*a21*a44*a53+a11*a25*a44*a53+a14*a21*a45*a53-   &
a11*a24*a45*a53-a15*a23*a41*a54+a13*a25*a41*a54+a15*a21*a43*a54-   &
a11*a25*a43*a54-a13*a21*a45*a54+a11*a23*a45*a54+a14*a23*a41*a55-   &
a13*a24*a41*a55-a14*a21*a43*a55+a11*a24*a43*a55+a13*a21*a44*a55-   &
a11*a23*a44*a55

b(4,2) = a15*a24*a33*a51-a14*a25*a33*a51-a15*a23*a34*a51+      &
a13*a25*a34*a51+a14*a23*a35*a51-a13*a24*a35*a51-a15*a24*a31*a53+   &
a14*a25*a31*a53+a15*a21*a34*a53-a11*a25*a34*a53-a14*a21*a35*a53+   &
a11*a24*a35*a53+a15*a23*a31*a54-a13*a25*a31*a54-a15*a21*a33*a54+   &
a11*a25*a33*a54+a13*a21*a35*a54-a11*a23*a35*a54-a14*a23*a31*a55+   &
a13*a24*a31*a55+a14*a21*a33*a55-a11*a24*a33*a55-a13*a21*a34*a55+   &
a11*a23*a34*a55

b(5,2) = -a15*a24*a33*a41+a14*a25*a33*a41+a15*a23*a34*a41-     &
a13*a25*a34*a41-a14*a23*a35*a41+a13*a24*a35*a41+a15*a24*a31*a43-   &
a14*a25*a31*a43-a15*a21*a34*a43+a11*a25*a34*a43+a14*a21*a35*a43-   &
a11*a24*a35*a43-a15*a23*a31*a44+a13*a25*a31*a44+a15*a21*a33*a44-   &
a11*a25*a33*a44-a13*a21*a35*a44+a11*a23*a35*a44+a14*a23*a31*a45-   &
a13*a24*a31*a45-a14*a21*a33*a45+a11*a24*a33*a45+a13*a21*a34*a45-   &
a11*a23*a34*a45

b(1,3) = a25*a34*a42*a51-a24*a35*a42*a51-a25*a32*a44*a51+      &
a22*a35*a44*a51+a24*a32*a45*a51-a22*a34*a45*a51-a25*a34*a41*a52+   &
a24*a35*a41*a52+a25*a31*a44*a52-a21*a35*a44*a52-a24*a31*a45*a52+   &
a21*a34*a45*a52+a25*a32*a41*a54-a22*a35*a41*a54-a25*a31*a42*a54+   &
a21*a35*a42*a54+a22*a31*a45*a54-a21*a32*a45*a54-a24*a32*a41*a55+   &
a22*a34*a41*a55+a24*a31*a42*a55-a21*a34*a42*a55-a22*a31*a44*a55+   &
a21*a32*a44*a55

b(2,3) = -a15*a34*a42*a51+a14*a35*a42*a51+a15*a32*a44*a51-     &
a12*a35*a44*a51-a14*a32*a45*a51+a12*a34*a45*a51+a15*a34*a41*a52-   &
a14*a35*a41*a52-a15*a31*a44*a52+a11*a35*a44*a52+a14*a31*a45*a52-   &
a11*a34*a45*a52-a15*a32*a41*a54+a12*a35*a41*a54+a15*a31*a42*a54-   &
a11*a35*a42*a54-a12*a31*a45*a54+a11*a32*a45*a54+a14*a32*a41*a55-   &
a12*a34*a41*a55-a14*a31*a42*a55+a11*a34*a42*a55+a12*a31*a44*a55-   &
a11*a32*a44*a55

b(3,3) = a15*a24*a42*a51-a14*a25*a42*a51-a15*a22*a44*a51+      &
a12*a25*a44*a51+a14*a22*a45*a51-a12*a24*a45*a51-a15*a24*a41*a52+   &
a14*a25*a41*a52+a15*a21*a44*a52-a11*a25*a44*a52-a14*a21*a45*a52+   &
a11*a24*a45*a52+a15*a22*a41*a54-a12*a25*a41*a54-a15*a21*a42*a54+   &
a11*a25*a42*a54+a12*a21*a45*a54-a11*a22*a45*a54-a14*a22*a41*a55+   &
a12*a24*a41*a55+a14*a21*a42*a55-a11*a24*a42*a55-a12*a21*a44*a55+   &
a11*a22*a44*a55

b(4,3) = -a15*a24*a32*a51+a14*a25*a32*a51+a15*a22*a34*a51-     &
a12*a25*a34*a51-a14*a22*a35*a51+a12*a24*a35*a51+a15*a24*a31*a52-   &
a14*a25*a31*a52-a15*a21*a34*a52+a11*a25*a34*a52+a14*a21*a35*a52-   &
a11*a24*a35*a52-a15*a22*a31*a54+a12*a25*a31*a54+a15*a21*a32*a54-   &
a11*a25*a32*a54-a12*a21*a35*a54+a11*a22*a35*a54+a14*a22*a31*a55-   &
a12*a24*a31*a55-a14*a21*a32*a55+a11*a24*a32*a55+a12*a21*a34*a55-   &
a11*a22*a34*a55

b(5,3) = a15*a24*a32*a41-a14*a25*a32*a41-a15*a22*a34*a41+      &
a12*a25*a34*a41+a14*a22*a35*a41-a12*a24*a35*a41-a15*a24*a31*a42+   &
a14*a25*a31*a42+a15*a21*a34*a42-a11*a25*a34*a42-a14*a21*a35*a42+   &
a11*a24*a35*a42+a15*a22*a31*a44-a12*a25*a31*a44-a15*a21*a32*a44+   &
a11*a25*a32*a44+a12*a21*a35*a44-a11*a22*a35*a44-a14*a22*a31*a45+   &
a12*a24*a31*a45+a14*a21*a32*a45-a11*a24*a32*a45-a12*a21*a34*a45+   &
a11*a22*a34*a45

b(1,4) = -a25*a33*a42*a51+a23*a35*a42*a51+a25*a32*a43*a51-     &
a22*a35*a43*a51-a23*a32*a45*a51+a22*a33*a45*a51+a25*a33*a41*a52-   &
a23*a35*a41*a52-a25*a31*a43*a52+a21*a35*a43*a52+a23*a31*a45*a52-   &
a21*a33*a45*a52-a25*a32*a41*a53+a22*a35*a41*a53+a25*a31*a42*a53-   &
a21*a35*a42*a53-a22*a31*a45*a53+a21*a32*a45*a53+a23*a32*a41*a55-   &
a22*a33*a41*a55-a23*a31*a42*a55+a21*a33*a42*a55+a22*a31*a43*a55-   &
a21*a32*a43*a55

b(2,4) = a15*a33*a42*a51-a13*a35*a42*a51-a15*a32*a43*a51+      &
a12*a35*a43*a51+a13*a32*a45*a51-a12*a33*a45*a51-a15*a33*a41*a52+   &
a13*a35*a41*a52+a15*a31*a43*a52-a11*a35*a43*a52-a13*a31*a45*a52+   &
a11*a33*a45*a52+a15*a32*a41*a53-a12*a35*a41*a53-a15*a31*a42*a53+   &
a11*a35*a42*a53+a12*a31*a45*a53-a11*a32*a45*a53-a13*a32*a41*a55+   &
a12*a33*a41*a55+a13*a31*a42*a55-a11*a33*a42*a55-a12*a31*a43*a55+   &
a11*a32*a43*a55

b(3,4) = -a15*a23*a42*a51+a13*a25*a42*a51+a15*a22*a43*a51-     &
a12*a25*a43*a51-a13*a22*a45*a51+a12*a23*a45*a51+a15*a23*a41*a52-   &
a13*a25*a41*a52-a15*a21*a43*a52+a11*a25*a43*a52+a13*a21*a45*a52-   &
a11*a23*a45*a52-a15*a22*a41*a53+a12*a25*a41*a53+a15*a21*a42*a53-   &
a11*a25*a42*a53-a12*a21*a45*a53+a11*a22*a45*a53+a13*a22*a41*a55-   &
a12*a23*a41*a55-a13*a21*a42*a55+a11*a23*a42*a55+a12*a21*a43*a55-   &
a11*a22*a43*a55

b(4,4) = a15*a23*a32*a51-a13*a25*a32*a51-a15*a22*a33*a51+      &
a12*a25*a33*a51+a13*a22*a35*a51-a12*a23*a35*a51-a15*a23*a31*a52+   &
a13*a25*a31*a52+a15*a21*a33*a52-a11*a25*a33*a52-a13*a21*a35*a52+   &
a11*a23*a35*a52+a15*a22*a31*a53-a12*a25*a31*a53-a15*a21*a32*a53+   &
a11*a25*a32*a53+a12*a21*a35*a53-a11*a22*a35*a53-a13*a22*a31*a55+   &
a12*a23*a31*a55+a13*a21*a32*a55-a11*a23*a32*a55-a12*a21*a33*a55+   &
a11*a22*a33*a55

b(5,4) = -a15*a23*a32*a41+a13*a25*a32*a41+a15*a22*a33*a41-     &
a12*a25*a33*a41-a13*a22*a35*a41+a12*a23*a35*a41+a15*a23*a31*a42-   &
a13*a25*a31*a42-a15*a21*a33*a42+a11*a25*a33*a42+a13*a21*a35*a42-   &
a11*a23*a35*a42-a15*a22*a31*a43+a12*a25*a31*a43+a15*a21*a32*a43-   &
a11*a25*a32*a43-a12*a21*a35*a43+a11*a22*a35*a43+a13*a22*a31*a45-   &
a12*a23*a31*a45-a13*a21*a32*a45+a11*a23*a32*a45+a12*a21*a33*a45-   &
a11*a22*a33*a45

b(1,5) = a24*a33*a42*a51-a23*a34*a42*a51-a24*a32*a43*a51+      &
a22*a34*a43*a51+a23*a32*a44*a51-a22*a33*a44*a51-a24*a33*a41*a52+   &
a23*a34*a41*a52+a24*a31*a43*a52-a21*a34*a43*a52-a23*a31*a44*a52+   &
a21*a33*a44*a52+a24*a32*a41*a53-a22*a34*a41*a53-a24*a31*a42*a53+   &
a21*a34*a42*a53+a22*a31*a44*a53-a21*a32*a44*a53-a23*a32*a41*a54+   &
a22*a33*a41*a54+a23*a31*a42*a54-a21*a33*a42*a54-a22*a31*a43*a54+   &
a21*a32*a43*a54

b(2,5) = -a14*a33*a42*a51+a13*a34*a42*a51+a14*a32*a43*a51-     &
a12*a34*a43*a51-a13*a32*a44*a51+a12*a33*a44*a51+a14*a33*a41*a52-   &
a13*a34*a41*a52-a14*a31*a43*a52+a11*a34*a43*a52+a13*a31*a44*a52-   &
a11*a33*a44*a52-a14*a32*a41*a53+a12*a34*a41*a53+a14*a31*a42*a53-   &
a11*a34*a42*a53-a12*a31*a44*a53+a11*a32*a44*a53+a13*a32*a41*a54-   &
a12*a33*a41*a54-a13*a31*a42*a54+a11*a33*a42*a54+a12*a31*a43*a54-   &
a11*a32*a43*a54

b(3,5) = a14*a23*a42*a51-a13*a24*a42*a51-a14*a22*a43*a51+      &
a12*a24*a43*a51+a13*a22*a44*a51-a12*a23*a44*a51-a14*a23*a41*a52+   &
a13*a24*a41*a52+a14*a21*a43*a52-a11*a24*a43*a52-a13*a21*a44*a52+   &
a11*a23*a44*a52+a14*a22*a41*a53-a12*a24*a41*a53-a14*a21*a42*a53+   &
a11*a24*a42*a53+a12*a21*a44*a53-a11*a22*a44*a53-a13*a22*a41*a54+   &
a12*a23*a41*a54+a13*a21*a42*a54-a11*a23*a42*a54-a12*a21*a43*a54+   &
a11*a22*a43*a54

b(4,5) = -a14*a23*a32*a51+a13*a24*a32*a51+a14*a22*a33*a51-     &
a12*a24*a33*a51-a13*a22*a34*a51+a12*a23*a34*a51+a14*a23*a31*a52-   &
a13*a24*a31*a52-a14*a21*a33*a52+a11*a24*a33*a52+a13*a21*a34*a52-   &
a11*a23*a34*a52-a14*a22*a31*a53+a12*a24*a31*a53+a14*a21*a32*a53-   &
a11*a24*a32*a53-a12*a21*a34*a53+a11*a22*a34*a53+a13*a22*a31*a54-   &
a12*a23*a31*a54-a13*a21*a32*a54+a11*a23*a32*a54+a12*a21*a33*a54-   &
a11*a22*a33*a54

b(5,5) = a14*a23*a32*a41-a13*a24*a32*a41-a14*a22*a33*a41+      &
a12*a24*a33*a41+a13*a22*a34*a41-a12*a23*a34*a41-a14*a23*a31*a42+   &
a13*a24*a31*a42+a14*a21*a33*a42-a11*a24*a33*a42-a13*a21*a34*a42+   &
a11*a23*a34*a42+a14*a22*a31*a43-a12*a24*a31*a43-a14*a21*a32*a43+   &
a11*a24*a32*a43+a12*a21*a34*a43-a11*a22*a34*a43-a13*a22*a31*a44+   &
a12*a23*a31*a44+a13*a21*a32*a44-a11*a23*a32*a44-a12*a21*a33*a44+   &
a11*a22*a33*a44

!...Transpose
bt = transpose(b)
endif

!...Multiplying the factor
if(n.lt.5)then
b = b/det
else
b = bt/det
endif

!...Output
!if(abs(det).le.1d-12)then
!print*,'The Matrix determinant is zero!',n,det
!stop
!endif
end


!
! Example illustrating the use of the frand123 C interface for the generation
! of double precision uniformly distributed random numbers.
! The example uses a naive Monte-Carlo approach to approximate pi.
!
! It generates points within the unit square and computes the ratio of points
! within the upper right quadrant of the unit circle.
! This ratio approximates pi / 4
!

program piDouble
   use, intrinsic :: iso_c_binding, only: c_double
   use omp_lib, only: omp_get_wtime
   use frand123, only: frand123State_t, frand123Init, frand123Double
   implicit none

   ! integer kind for large integers
   integer, parameter :: ik = selected_int_kind( 10 )

   ! number of points used for the approximation
   integer( kind = ik ), parameter :: numberOfPoints = 1000 * 1000 * 100

   ! state for frand123
   type( frand123State_t ) :: state

   ! timing variables
   real( kind = c_double ) :: startTime, endTime

   ! result variables
   real( kind = c_double ) :: varPiScalar, varPiTwo, varPi2000

   ! initialize state
   call frand123Init( state, 0, 0 )

   ! use piScalar
   startTime = omp_get_wtime()
   varPiScalar = piScalar( state )
   endTime = omp_get_wtime()
   write(*, '( "Result generating  one random number at a time: ", ES11.4, &
          & " took ", ES11.4, " seconds" )' ) varPiScalar, endTime - startTime

   ! use piTwo
   startTime = omp_get_wtime()
   varPiTwo = piTwo( state )
   endTime = omp_get_wtime()
   write(*, '( "Result generating  two random number at a time: ", ES11.4, &
          & " took ", ES11.4, " seconds" )' ) varPiTwo, endTime - startTime

   ! use pi2000
   startTime = omp_get_wtime()
   varPi2000 = pi2000( state )
   endTime = omp_get_wtime()
   write(*, '( "Result generating 2000 random number at a time: ", ES11.4, &
          & " took ", ES11.4, " seconds" )' ) varPiTwo, endTime - startTime

contains

   ! comput pi drawing a single double precision uniformly distributed random
   ! number at a time
   real( kind = c_double ) function piScalar( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! local variables
      integer( kind = ik ) :: inside ! counter for points inside unit circle
      integer( kind = ik ) :: i ! loop variable
      real( kind = c_double ) :: x, y ! coordinates of the point
      real( kind = c_double ) :: r2 ! square of the distance to (0,0)

      ! approximate pi
      inside = 0
      do i = 1, numberOfPoints
         ! generate point in the unit square
         call frand123Double( state, x )
         call frand123Double( state, y )
         ! compute square of radius and check whether inside unit circle
         r2 = x * x + y * y
         if( r2 .lt. 1.d0 ) then
            inside = inside + 1
         endif
      enddo
      ! pi = 4 * ratio between points inside unit circle and points generated
      piScalar = 4.d0 * real( inside, c_double ) / &
                        real( numberOfPoints, c_double )
   end function piScalar

   ! comput pi drawing two double precision uniformly distributed random
   ! number at a time
   real( kind = c_double ) function piTwo( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! local variables
      integer( kind = ik ) :: inside ! counter for points inside unit circle
      integer( kind = ik ) :: i ! loop variable
      real( kind = c_double ), dimension( 2 ) :: pos ! coordinates of the point
      real( kind = c_double ) :: r2 ! square of the distance to (0,0)

      ! approximate pi
      inside = 0
      do i = 1, numberOfPoints
         ! generate point in the unit square
         call frand123Double( state, pos )
         ! compute square of radius and check whether inside unit circle
         r2 = sum( pos ** 2 )
         if( r2 .lt. 1.d0 ) then
            inside = inside + 1
         endif
      enddo
      ! pi = 4 * ratio between points inside unit circle and points generated
      piTwo = 4.d0 * real( inside, c_double ) / &
                     real( numberOfPoints, c_double )
   end function piTwo

   ! comput pi drawing 2000 double precision uniformly distributed random
   ! number at a time
   real( kind = c_double ) function pi2000( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! local variables
      integer( kind = ik ) :: inside ! counter for points inside unit circle
      integer( kind = ik ) :: i, j ! loop variables
      real( kind = c_double ), dimension( 2000 ) :: buffer ! buffer for RNG
      real( kind = c_double ) :: r2 ! square of the distance to (0,0)

      ! approximate pi
      inside = 0
      do i = 1, numberOfPoints, 1000
         ! generate point in the unit square
         call frand123Double( state, buffer )
         do j = 1, 1000
            ! compute square of radius and check whether inside unit circle
            r2 = sum( buffer( 2 * j - 1:2 * j ) ** 2 )
            if( r2 .lt. 1.d0 ) then
               inside = inside + 1
            endif
         enddo
      enddo
      ! pi = 4 * ratio between points inside unit circle and points generated
      pi2000 = 4.d0 * real( inside, c_double ) / &
                      real( numberOfPoints, c_double )
   end function pi2000
end program piDouble


program tarefaa
    implicit real(8) (a-h,o-z)
    parameter (pi = 4d0*atan(1d0))

    g = 9.8d0
    a_l = 9.8d0
    a_m = 1d0
    dt = 1d-3
    tmax = 120d0
    omega_i = 0d0
    theta_i = pi/15
    i = 0

    open(10, file='saida-a1-10407962.dat')

    do while ( i*dt.le.tmax )

        theta_i = mod(theta_i, 2*pi)

        omega_j = omega_i - g*theta_i*dt/a_l
        theta_j = theta_i + omega_i*dt

        omega_i = omega_j
        theta_i = theta_j

        Ec = 0.5*a_m*(omega_i*a_l)**2
        Ep = a_m*g*a_l*(1-cos(theta_i))

        write(10, '(F0.16,3(" ",F0.16))') i*dt, theta_i, Ec+Ep
        i = i+1
    end do

    close(10)

    omega_i = 0d0
    theta_i = pi/15
    i = 0

    open(10, file='saida-a2-10407962.dat')

    do while ( i*dt.le.tmax )

        theta_i = mod(theta_i, 2*pi)

        omega_i = omega_i - g*theta_i*dt/a_l
        theta_i = theta_i + omega_i*dt

        Ec = 0.5*a_m*(omega_i*a_l)**2
        Ep = a_m*g*a_l*(1-cos(theta_i))

        write(10, '(F0.16,2(" ",F0.16))') i*dt, theta_i, Ec+Ep
        i = i+1
    end do

    close(10)
end program tarefaa


! $UWHPSC/adaptive_quadtrature/factorial_example.f90

! Illustrate a recursive subroutine to compute n! = n*(n-1)*(n-2)...3*2*1

program factorial_example

    implicit none
    integer :: n, nfact

    print *, "Compute n! recursively.  Input n..."
    read *, n
    call myfactorial(n,nfact)
    print *, "n!  = ", nfact

contains

    recursive subroutine myfactorial(m,mfact)
    implicit none
    integer, intent(in) :: m
    integer, intent(out) :: mfact
    integer :: m1fact

    if (m <= 1) then
        mfact = 1
    else
        call myfactorial(m-1, m1fact)
        mfact = m * m1fact
    endif
    end subroutine myfactorial

end program factorial_example


PROGRAM Test_SVD

! A simple test of the SVD module.

! The matrix:

!  ( 1  2  3 )
!  ( 4  5  6 )
!  ( 7  8  9 )
!  (10 11 12 )

! has singular values: 25.4624, 1.2907 and zero.

USE SVD
IMPLICIT NONE

REAL (dp)  :: e(3), x(4,3), s(4), u(4,4), v(3,3), value
INTEGER    :: info, row, col

value = 1.0_dp
DO row = 1, 4
  DO col = 1, 3
    x(row,col) = value
    value = value + 1.0_dp
  END DO
END DO

CALL dsvdc(x, 4, 3, s, e, u, v, 11, info)

! Output the singular values

WRITE(*, 900) s(1:4)
900 FORMAT(' The calculated singular values = ', 4f10.4/)

! Output the U matrix

WRITE(*, *) '     The U-matrix'
DO row = 1, 4
  WRITE(*, 910) u(row,1:4)
  910 FORMAT(4f10.4)
END DO

! Now the right-hand or V-matrix

WRITE(*, *)
WRITE(*, *) '     The V-matrix'
DO row = 1, 3
  WRITE(*, 910) v(row,1:3)
END DO

STOP
END PROGRAM Test_SVD


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran77 Subroutines and Programs         *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
! ... A test program illustrating the
!     use of subroutine vshifte (see documentation for vshifte)
!
!
!     Let the analytic vector field (u, v) in geophysical coordinates be
!     given by
!
!          u  = -exp(x)*sin(p) + exp(-z)*cos(p) + exp(y)*sin(t)*sin(p)
!
!          v  = exp(y)*cos(p) + exp(z)*cos(t) - exp(x)*sin(t)*cos(p)
!
!     where t is the latitude coordinate, p is the longitude coordinate,
!     and x=cos(t)*cos(p), y=cos(t)*sin(p), z=sin(t) are the cartesian coordinates
!     restricted to the sphere.

!     The "offset" vector field (uoff, voff) is set equal to (u, v).
!     This is transferred to the "regular" grid in (ureg, vreg).  (ureg, vreg)
!     is then compared with (u, v) on the regular grid.  Finally (ureg, vreg)
!     is transferred back to (uoff, voff) which is again compared with (u, v).
!     The least squares error after each transformation with vshifte
!     is computed and printed.  Results from running the program on
!     a 2.5 degree equally spaced regular and offset grid is given.
!     Output from runs on separate platforms with 32 bit and 64 bit
!     floating point arithmetic is listed.
!
! *********************************************
!     OUTPUT
! *********************************************
!
!       vshifte arguments
!       ioff =  0 nlon = 144 nlat =  72
!       lsave =   608 lwork = 21024
!       ier =  0
!       least squares error
! ***   32 BIT ARITHMETIC
!       err2u =  0.377E-06 err2v =  0.328E-06
! ***   64 BIT ARITHMETIC
!       err2u =  0.777E-13 err2v =  0.659E-13

!       vshifte arguments
!       ioff =  1 nlon = 144 nlat =  72
!       lsave =   608 lwork = 21024
!       ier =  0
!       least squares error
! ***   32 BIT ARITHMETIC
!       err2u =  0.557E-06 err2v =  0.434E-06
! ***   64 BIT AIRTHMETIC
!       err2u =  0.148E-12 err2v =  0.118E-12
!
! *********************************************
!     END OF OUTPUT (CODE FOLLOWS)
! *********************************************
!
program testvshifte

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter :: nlon = 144, nlat = 72
    integer(ip), parameter :: nlatp1 = nlat+1
    integer(ip) :: ioff, i, j, error_flag
    real(wp) :: dlat, dlon, half_dlat, half_dlon, lat, long, x, y, z, ex, ey, ez, emz
    real(wp) :: err2u, err2v, ue, ve, sint, sinp, cost, cosp
    real(wp) :: uoff(nlon, nlat), voff(nlon, nlat)
    real(wp) :: ureg(nlon, nlatp1), vreg(nlon, nlatp1)
    real(wp), allocatable :: wavetable(:)
    real(wp), parameter   :: ZERO = 0.0_wp

    ! Set grid increments
    dlat = PI/nlat
    dlon = TWO_PI/nlon
    half_dlat = dlat/2
    half_dlon = dlon/2

    ! Set (uoff, voff) = (u, v) on offset grid
    do j=1, nlon
        long = half_dlon + real(j - 1, kind=wp) * dlon
        sinp = sin(long)
        cosp = cos(long)
        do i=1, nlat
            lat = -HALF_PI + half_dlat + real(i - 1, kind=wp) * dlat
            sint = sin(lat)
            cost = cos(lat)
            x = cost*cosp
            y = cost*sinp
            z = sint
            ex = exp(x)
            ey = exp(y)
            ez = exp(z)
            emz = exp(-z)
            uoff(j, i) =-ex*sinp+emz*cost+ey*sint*sinp
            voff(j, i) = ey*cosp+ez*cost-ex*sint*cosp
        end do
    end do

    ! Initialize wsav for offset to regular shift
    ioff = 0
    call initialize_vshifte(ioff, nlon, nlat, wavetable, error_flag)

    ! Write input arguments to vshifte
    write (stdout, 100) ioff, nlon, nlat
100 format(' vshifte arguments', &
        /' ioff = ', i2, ' nlon = ', i3, ' nlat = ', i3)

    ! Shift offset to regular grid
    call vshifte(ioff, nlon, nlat, uoff, voff, ureg, vreg, wavetable, error_flag)

    write (stdout, 200) error_flag
200 format(' ier = ', i2)

    if (error_flag == 0) then
        ! Compute error in ureg, vreg
        err2u = ZERO
        err2v = ZERO
        do j=1, nlon
            long = real(j - 1, kind=wp) * dlon
            sinp = sin(long)
            cosp = cos(long)
            do i=1, nlat+1
                lat = -HALF_PI + real(i - 1, kind=wp) * dlat
                sint = sin(lat)
                cost = cos(lat)
                x = cost*cosp
                y = cost*sinp
                z = sint
                ex = exp(x)
                ey = exp(y)
                ez = exp(z)
                emz = exp(-z)
                ue = -ex*sinp+emz*cost+ey*sint*sinp
                ve = ey*cosp+ez*cost-ex*sint*cosp
                err2u = err2u + (ureg(j, i)-ue)**2
                err2v = err2v + (vreg(j, i)-ve)**2
            end do
        end do
        err2u = sqrt(err2u/(nlon*(nlat + 1)))
        err2v = sqrt(err2v/(nlon*(nlat + 1)))
        write (stdout, 300) err2u, err2v
300     format(' least squares error ', &
            /' err2u = ', e10.3, ' err2v = ', e10.3)
    end if

    ! Initialize wsav for regular to offset shift
    ioff = 1
    call initialize_vshifte(ioff, nlon, nlat, wavetable, error_flag)

    ! Transfer regular grid values in (ureg, vreg) to offset grid in (uoff, voff)
    uoff = ZERO
    voff = ZERO

    write (stdout, 100) ioff, nlon, nlat

    call vshifte(ioff, nlon, nlat, uoff, voff, ureg, vreg, wavetable, error_flag)

    write (stdout, 200) error_flag

    if (error_flag == 0) then
        !     compute error in uoff, voff
        err2u = ZERO
        err2v = ZERO
        do j=1, nlon
            long = half_dlon+(j-1)*dlon
            sinp = sin(long)
            cosp = cos(long)
            do i=1, nlat
                lat = -HALF_PI + half_dlat + real(i - 1, kind=wp) * dlat
                sint = sin(lat)
                cost = cos(lat)
                x = cost*cosp
                y = cost*sinp
                z = sint
                ex = exp(x)
                ey = exp(y)
                ez = exp(z)
                emz = exp(-z)
                ue = -ex*sinp+emz*cost+ey*sint*sinp
                ve = ey*cosp+ez*cost-ex*sint*cosp
                err2u = err2u + (uoff(j, i)-ue)**2
                err2v = err2v + (voff(j, i)-ve)**2
            end do
        end do
        err2u = sqrt(err2u/(nlon*(nlat + 1)))
        err2v = sqrt(err2v/(nlon*(nlat + 1)))
        write (stdout, 300) err2u, err2v
    end if

    ! Release memory
    deallocate (wavetable)

end program testvshifte


PROGRAM main

  USE mo_kind,      ONLY: i4, dp, sp
  use mo_ansi_colors, only: color, c_red, c_green
  USE mo_linfit,    ONLY: linfit

  IMPLICIT NONE

  ! data
  INTEGER(i4), PARAMETER :: nn = 100

  REAL(dp), DIMENSION(nn) :: xx, yy, yout
  REAL(dp) :: a, b, a2, b2, siga, sigb, chi2

  REAL(sp), DIMENSION(nn) :: sxx, syy, syout
  REAL(sp) :: sa, sb, sa2, sb2, ssiga, ssigb, schi2

  LOGICAL  :: model2
  LOGICAL :: isgood

  Write(*,*) ''
  Write(*,*) 'Test mo_linfit.f90'

  isgood = .true.

  ! Double precision
  a = 2._dp
  b = 3._dp
  call random_number(xx)
  yy = a + b*xx

  ! model I
  model2 = .false.
  ! fit should be perfect
  yout = linfit(xx, yy, a=a2, b=b2, siga=siga, sigb=sigb, chi2=chi2, model2=model2)
  yout = yout
  if (abs(a-a2) > 100._dp*epsilon(1.0_dp)) isgood = .false.
  if (siga > 100._dp*epsilon(1.0_dp)) isgood = .false.
  if (sigb > 100._dp*epsilon(1.0_dp)) isgood = .false.
  if (chi2 > epsilon(1.0_dp)) isgood = .false.

  ! model II
  model2 = .true.
  yout = linfit(xx, yy, a=a2, b=b2, siga=siga, sigb=sigb, chi2=chi2, model2=model2)
  yout = yout
  if (abs(a-a2) > 100._dp*epsilon(1.0_dp)) isgood = .false.
  if (siga > 1.0e-4*a) isgood = .false.
  if (sigb > 1.0e-4*b) isgood = .false.
  if (chi2 > epsilon(1.0_dp)) isgood = .false.

  ! Single precision
  sa = 2._sp
  sb = 3._sp
  call random_number(sxx)
  syy = sa + sb*sxx

  ! model I
  model2 = .false.
  ! fit should be perfect
  syout = linfit(sxx, syy, a=sa2, b=sb2, siga=ssiga, sigb=ssigb, chi2=schi2, model2=model2)
  syout = syout
  if (abs(sa-sa2) > 100._sp*epsilon(1.0_sp)) isgood = .false.
  if (ssiga > 100._sp*epsilon(1.0_sp)) isgood = .false.
  if (ssigb > 100._sp*epsilon(1.0_sp)) isgood = .false.
  if (schi2 > epsilon(1.0_sp)) isgood = .false.

  ! model II
  model2 = .true.
  syout = linfit(sxx, syy, a=sa2, b=sb2, siga=ssiga, sigb=ssigb, chi2=schi2, model2=model2)
  syout = syout
  if (abs(sa-sa2) > 100._sp*epsilon(1.0_sp)) isgood = .false.
  if (ssiga > 1.0e-4*sa) isgood = .false.
  if (ssigb > 1.0e-4*sb) isgood = .false.
  if (schi2 > epsilon(1.0_sp)) isgood = .false.

  if (isgood) then
     write(*,*) 'mo_linfit ', color('o.k.', c_green)
  else
     write(*,*) 'mo_linfit ', color('failed!', c_red)
  endif

END PROGRAM main


C PROGRAM FOR DIAGONALIZING A SYMMETRIC MATRIX USING JACOBI METHOD
C GAURAV RUDRA MALIK R.NO:23
	DIMENSION A(5,5),U(5,5),UT(5,5),S1(5,5),S(5,5)
	WRITE(*,*)'ENTER THE MATRIX ORDER, MAX:5'
	READ(*,*)N
50	WRITE(*,*)'ENTER THE MATRIX ELEMENTS FOR THE SYMMETRIC MATRIX'
	DO 2 I=1,N
	DO 1 J=1,N
	READ(*,*)A(I,J)
1	CONTINUE
2	CONTINUE
	DO 4 I=1,N
	DO 3 J=1,N
	IF(I.NE.J)THEN
	IF(A(I,J).NE.A(J,I))THEN
	WRITE(*,*)'DIAGONALIZATION NOT POSSIBLE'
	GOTO 50
	ENDIF
	ENDIF
3	CONTINUE
4	CONTINUE
	WRITE(*,*)'ENTER THE NUMBER OF ITERATIONS'
	READ(*,*)M
	DO 70 IJ=1,M
C INITIALIZING THE TRANSFORMATION MATRIX AS IDENTITY
	DO 6 I=1,N
	U(I,I)=1.0
	DO 5 J=1,N
	IF(I.NE.J)THEN
	U(I,J)=0.0
	ENDIF
5	CONTINUE
6	CONTINUE
C LARGEST OFF DIAGONAL
	L=A(1,2)
	DO 8 I=2,N
	DO 7 J=2,I
	IF(A(I,J).GT.L)THEN
	L=A(I,J)
	II=I
	JJ=J
	ENDIF
7	CONTINUE
8	CONTINUE
	TH=0.5*ATAN((2*L)/(A(II,II)-A(JJ,JJ)))
	U(II,II)=COS(TH)
	U(JJ,JJ)=COS(TH)
	U(II,JJ)=SIN(TH)
	U(JJ,II)=SIN(TH)*(-1)
C TRANSPOSE
	DO 10 I=1,N
	DO 9 J=1,N
	UT(I,J)=U(J,I)
9	CONTINUE
10	CONTINUE
C MULTIPLICATION
	DO 13 I=1,N
	DO 12 J=1,N
	S1(I,J)=0.0
	DO 11 K=1,N
	S1(I,J)=S1(I,J) + A(I,K)*U(K,J)
11	CONTINUE
12	CONTINUE
13	CONTINUE
	DO 16 I=1,N
	DO 15 J=1,N
	S(I,J)=0.0
	DO 14 K=1,N
	S(I,J)=S(I,J) + UT(I,K)*S1(K,J)
14	CONTINUE
15	CONTINUE
16	CONTINUE
	DO 19 I=1,N
	DO 18 J=1,N
	A(I,J)=S(I,J)
18	CONTINUE
19	CONTINUE
70	CONTINUE
C RESULT DISPLAY
	WRITE(*,*)'THE DIAGONALIZED MATRIX IS:'
	DO 21 I=1,N
	WRITE(*,22)(A(I,J),j=1,n)
21	CONTINUE
22	FORMAT(3(F8.4,5X))
	STOP
	END

RESULT:

 ENTER THE MATRIX ORDER, MAX:5
3
 ENTER THE MATRIX ELEMENTS FOR THE SYMMETRIC MATRIX
2
1
0
1
1
2
0
2
1
 ENTER THE NUMBER OF ITERATIONS
50
 THE DIAGONALIZED MATRIX IS:
  2.0000        .0002        .0007
   .0000        .7500        .0000
   .0000        .0000      -1.0000


program fibonacci
  implicit none

  integer(kind=16) get_fibo
  integer(kind=16) fibo_sum

  integer n

  print*, "Qué termino de la serie de fibonacci quieres?(4 bytes max)"
  read*, n

  print*, "El ",n,"-ésimo termino de la serie es: ",get_fibo(n)

  print*, "La suma de todos es:", fibo_sum(n)

end program

recursive function get_fibo(limit) result(res)
  implicit none

  integer(kind=16) res
  integer, intent(in) :: limit

  if (limit <= 2) then
    res = 1
  else
    res = get_fibo(limit-1) + get_fibo(limit-2)
  end if

end function get_fibo

integer(kind=16) function fibo_sum(limit)
  implicit none

  integer(kind=16) get_fibo

  integer(kind=16) :: ans = 0
  integer, intent(in) :: limit
  integer :: i

  do i=0, limit
    ans = get_fibo(i) + ans
  end do

  fibo_sum = ans-1

end function fibo_sum


program mean_time_of_day
  implicit none
  integer(kind=4), parameter :: dp = kind(0.0d0)

  type time_t
    integer(kind=4) :: hours, minutes, seconds
  end type

  character(len=8), dimension(4), parameter :: times = &
    (/ '23:00:17', '23:40:20', '00:12:45', '00:17:19' /)
  real(kind=dp), dimension(size(times)) :: angles
  real(kind=dp) :: mean

  angles = time_to_angle(str_to_time(times))
  mean = mean_angle(angles)
  if (mean < 0) mean = 360 + mean

  write(*, fmt='(I2.2, '':'', I2.2, '':'', I2.2)') angle_to_time(mean)
contains
  real(kind=dp) function mean_angle(angles)
    real(kind=dp), dimension(:), intent (in) :: angles
    real(kind=dp) :: x, y

    x = sum(sin(radians(angles)))/size(angles)
    y = sum(cos(radians(angles)))/size(angles)

    mean_angle = degrees(atan2(x, y))
  end function

  elemental real(kind=dp) function radians(angle)
    real(kind=dp), intent (in) :: angle
    real(kind=dp), parameter :: pi = 4d0*atan(1d0)
    radians = angle/180*pi
  end function

  elemental real(kind=dp) function degrees(angle)
    real(kind=dp), intent (in) :: angle
    real(kind=dp), parameter :: pi = 4d0*atan(1d0)
    degrees = 180*angle/pi
  end function

  elemental type(time_t) function str_to_time(str)
    character(len=*), intent (in) :: str
    ! Assuming time in format hh:mm:ss
    read(str, fmt='(I2, 1X, I2, 1X, I2)') str_to_time
  end function

  elemental real(kind=dp) function time_to_angle(time) result (res)
    type(time_t), intent (in) :: time

    real(kind=dp) :: seconds
    real(kind=dp), parameter :: seconds_in_day = 24*60*60

    seconds = time%seconds + 60*time%minutes + 60*60*time%hours
    res = 360*seconds/seconds_in_day
  end function

  elemental type(time_t) function angle_to_time(angle)
    real(kind=dp), intent (in) :: angle

    real(kind=dp) :: seconds
    real(kind=dp), parameter :: seconds_in_day = 24*60*60

    seconds = seconds_in_day*angle/360d0
    angle_to_time%hours = int(seconds/60d0/60d0)
    seconds = mod(seconds, 60d0*60d0)
    angle_to_time%minutes = int(seconds/60d0)
    angle_to_time%seconds = mod(seconds, 60d0)
  end function
end program


PROGRAM demo

!     Program to demonstrate the use of module LSQ for unconstrained
!     linear least-squares regression.
!     The data on fuel consumption are from:
!     Sanford Weisberg `Applied Linear Regression', 2nd edition, 1985,
!     pages 35-36.   Publisher: Wiley

!     The program is designed so that users can easily edit it for their
!     problems.   If you are likely to have more than 500 cases then increase
!     the value of maxcases below.   Similarly, if you may have more than
!     30 predictor variables, change maxvar below.

!     The subscript 0 is used to relate to the constant in the model.
!     Module LSQ treats the constant in the model, if there is one, just as
!     any other variable.   The numbering of all arrays starts from 1 in LSQ.

USE lsq                      ! Must be the first declaration in the program
IMPLICIT NONE

INTEGER, PARAMETER :: maxcases = 500, maxvar = 30,                            &
                      max_cdim = maxvar*(maxvar+1)/2, lout = 6
INTEGER            :: case, nvar, iostatus, nreq, ifault, i, list(maxvar), j, &
                      in, i1, i2
REAL (dp)          :: xx(0:maxvar), yy, wt, one = 1.D0, beta(0:maxvar),       &
                      var, covmat(max_cdim), sterr(0:maxvar), hii,            &
                      cormat(max_cdim), ycorr(maxvar)
REAL (KIND(0.E0))  :: x(maxcases, maxvar), y(maxcases), t(0:maxvar), tmin,    &
                      r2, resid(maxcases), std_resid(maxcases), std_err_pred, &
                      fitted, stdev_res
CHARACTER (LEN=80) :: heading, output
CHARACTER (LEN= 2) :: state(50)
CHARACTER (LEN= 8) :: vname(0:maxvar), y_name
LOGICAL            :: fit_const, lindep(0:maxvar)

!     Interfaces

INTERFACE
  SUBROUTINE separate_text(heading, vname, nvar)
    IMPLICIT NONE
    CHARACTER (LEN = *), INTENT(IN OUT)            :: heading
    CHARACTER (LEN = *), DIMENSION(:), INTENT(OUT) :: vname
    INTEGER, INTENT(OUT)                           :: nvar
  END SUBROUTINE separate_text
END INTERFACE

INTERFACE
  SUBROUTINE printc(in, cormat, dimc, ycorr, vname, yname, iopt, lout, ier)
    USE lsq
    IMPLICIT NONE
    INTEGER, INTENT(IN)                          :: in, dimc, iopt, lout
    INTEGER, INTENT(OUT)                         :: ier
    REAL (dp), DIMENSION(:), INTENT(IN)          :: cormat, ycorr
    CHARACTER (LEN=*), DIMENSION(0:), INTENT(IN) :: vname
    CHARACTER (LEN=*), INTENT(IN)                :: yname
  END SUBROUTINE printc
END INTERFACE

WRITE(*, *)'The data on fuel consumption are from:'
WRITE(*, *)'Sanford Weisberg "Applied Linear Regression", 2nd edition, 1985,'
WRITE(*, *)'pages 35-36.   Publisher: Wiley   ISBN: 0-471-87957-6'
WRITE(*, *)

OPEN(8, file='fuelcons.dat', status='old')

!     The first line of this file contains the names of the variables.

READ(8, '(a)') heading

vname(0) = 'Constant'

!     Read the heading to get the variable names & the number of variables

CALL separate_text(heading, vname, nvar)

nvar = nvar - 2              ! nvar is the number of variables.
                             ! 1 is subtracted as the first field in this
                             ! file contains the abbreviated state name,
                             ! & 1 is subtracted for the Y-variable.
vname(1:nvar) = vname(2:nvar+1)
y_name = vname(nvar+2)

WRITE(*, *)'No. of variables =', nvar
WRITE(*, *)'Predictor variables are:'
WRITE(*, '(" ", 9a9)') vname(1:nvar)
WRITE(*, *)'Dependent variable is: ', y_name

fit_const = .true.           ! Change to .false. if fitting a model without
                             ! a constant.

CALL startup(nvar, fit_const)          ! Initializes the QR-factorization

!     Read in the data, one line at a time, and progressively update the
!     QR-factorization.

wt = one
case = 1

DO
  READ(8, *, IOSTAT=iostatus) state(case), x(case, 1:nvar), y(case)
  IF (iostatus > 0) CYCLE              ! Error in data
  IF (iostatus < 0) EXIT               ! End of file

  xx(0) = one                          ! A one is inserted as the first
                                       ! variable if a constant is being fitted.
  xx(1:nvar) = x(case, 1:nvar)         ! New variables and transformed variables
                                       ! will often be generated here.
  yy = y(case)
  CALL includ(wt, xx, yy)
  case = case + 1
END DO

WRITE(*, *)'No. of observations =', nobs

CALL sing(lindep, ifault)              ! Checks for singularities

IF (ifault == 0) THEN
  WRITE(*, *)'QR-factorization is not singular'
ELSE
  DO i = 1, nvar
    IF (lindep(i)) THEN
      WRITE(*, *) vname(i), ' is exactly linearly related to earlier variables'
    END IF
  END DO ! i = 1, nvar
END IF ! (ifault == 0)
WRITE(*, *)

!     Show correlations (IN = 1 for `usual' correlations)

in = 1
CALL partial_corr(in, cormat, max_cdim, ycorr, ifault)
CALL printc(in, cormat, max_cdim, ycorr, vname, y_name, 1, lout, ifault)
WRITE(*, *)
WRITE(*, *)'Press ENTER to continue'
READ(*, *)

!     Weisberg only uses variables TAX, INC, ROAD and DLIC.   These are
!     currently in positions 2, 4, 5 & 7.
!     We could have set NVAR = 4 and copied only these variables from X to
!     XX, but we will show how regressions can be performed for a subset
!     of the variables in the QR-factorization.   Routine REORDR will be used
!     to re-order the variables.

list(1:4) = (/ 2, 4, 5, 7/)
CALL reordr(list, 4, 2, ifault)        ! Re-order so that the first 4 variables
                                       ! appear in positions 2,3,4 & 5.
                                       ! N.B. Though variables # 2, 4, 5 & 7
                                       !      will occupy positions 2-5, they
                                       !      may be in any order.
                                       ! The constant remains in position 1.
WRITE(*, 910) (vname(vorder(1:ncol)))
910 FORMAT(' Current order of variables:'/' ', 8a9/)

!     Calculate regression coefficients of Y against the first variable, which
!     was just a constant = 1.0, and the next 4 predictors.

CALL tolset()                          ! Calculate tolerances before calling
                                       ! subroutine regcf.
nreq = 5                               ! i.e. Const, TAX, INC, ROAD, DLIC
CALL regcf(beta, nreq, ifault)

CALL ss()                              ! Calculate residual sums of squares

!     Calculate covariance matrix of the regression coefficients & their
!     standard errors.

var = rss(nreq) / (nobs - nreq)
CALL cov(nreq, var, covmat, max_cdim, sterr, ifault)

!     Calculate t-values

t(0:nreq-1) = beta(0:nreq-1) / sterr(0:nreq-1)

!     Output regression table, residual sums of squares, and R-squared.

WRITE(*, *)
WRITE(*, *)'Variable   Regn.coeff.   Std.error  t-value   Res.sum of sq.'
DO i = 0, nreq-1
  WRITE(*, 900) vname(vorder(i+1)), beta(i), sterr(i), t(i), rss(i+1)
  900 FORMAT(' ', a8, '  ', g12.4, '  ', g11.4, ' ', f7.2, '  ', g14.6)
END DO
WRITE(*, *)

!     Output correlations of the parameter estimates

WRITE(*, *) 'Covariances of parameter estimates'
i2 = nreq
DO i = 1, nreq-1
  i1 = i2 + 1
  i2 = i2 + nreq - i
  WRITE(output, '(" ", a8)') vname(vorder(i+1))
  WRITE(output(10*i:), '(7f10.3)') covmat(i1:i2)
  WRITE(*, '(a)') output
END DO
WRITE(*, *)

!     Now delete the variable with the smallest t-value by moving it
!     to position 5 and then repeating the calculations for the constant
!     and the next 3 variables.

j = 1
tmin = ABS(t(1))
DO i = 2, nreq-1
  IF (ABS(t(i)) < tmin) THEN
    j = i
    tmin = ABS(t(i))
  END IF
END DO
j = j + 1                    ! Add 1 as the t-array started at subscript 0

WRITE(*, *)'Removing variable in position', j
CALL vmove(j, nreq, ifault)
nreq = nreq - 1
CALL regcf(beta, nreq, ifault)
CALL ss()
CALL cov(nreq, var, covmat, max_cdim, sterr, ifault)
t(0:nreq-1) = beta(0:nreq-1) / sterr(0:nreq-1)

!     Output regression table, residual sums of squares, and R-squared.

WRITE(*, *)
WRITE(*, *)'Variable   Regn.coeff.   Std.error  t-value   Res.sum of sq.'
DO i = 0, nreq-1
  WRITE(*, 900) vname(vorder(i+1)), beta(i), sterr(i), t(i), rss(i+1)
END DO
WRITE(*, *)

var = rss(nreq)/(nobs - nreq)
stdev_res = SQRT( var )
r2 = one - rss(nreq) / rss(1)          ! RSS(1) is the rss if only the constant
                                       ! is fitted; RSS(nreq) is the rss after
                                       ! fitting the requested NREQ variables.
WRITE(*, '(" R^2 =", f8.4, "     Std. devn. of residuals =", g12.4/)')      &
      r2, stdev_res
WRITE(*, *)'N.B. Some statistical packages wrongly call the standard deviation'
WRITE(*, *)'     of the residuals the standard error of prediction'
WRITE(*, *)

!     Calculate residuals, hii, standardized residuals & standard errors of
!     prediction.

WRITE(*, *)'Press ENTER to continue'
READ(*, *)

WRITE(*, *)'State     Actual    Fitted  Residual  Std.resid.  SE(prediction)'
DO i = 1, nobs
  xx(0) = one
  DO j = 1, nreq-1
    xx(j) = x(i, vorder(j+1))          ! N.B. Regression coefficient j is for
                                       !      the variable vorder(j+1)
  END DO
  fitted = DOT_PRODUCT( beta(0:nreq-1), xx(0:nreq-1) )
  resid(i) = y(i) - fitted
  CALL hdiag(xx, nreq, hii, ifault)
  std_resid(i) = resid(i) / SQRT(var*(one - hii))
!     The sqrt was omitted from the initial version of this demo in line below.
  std_err_pred = sqrt( varprd(xx, nreq) )
  WRITE(*, 920) state(i), y(i), fitted, resid(i), std_resid(i), std_err_pred
  920 FORMAT('   ', a2, '  ', 3f10.1, f9.2, '     ', f10.0)

  IF (i .EQ. 24) THEN
    WRITE(*, *)'Press ENTER to continue'
    READ(*, *)
    WRITE(*, *)'State     Actual    Fitted  Residual  Std.resid.  SE(prediction)'
  END IF
END DO ! i = 1, nobs

STOP
END PROGRAM demo

SUBROUTINE separate_text(text, name, number)

!     Takes the character string in `text' and separates it into `names'.
!     This version only allows spaces as delimiters.

IMPLICIT NONE
CHARACTER (LEN = *), INTENT(IN OUT)            :: text
CHARACTER (LEN = *), DIMENSION(:), INTENT(OUT) :: name
INTEGER, INTENT(OUT)                           :: number

!     Local variables

INTEGER  :: length, len_name, pos1, pos2, nchars

length = LEN_TRIM(text)
number = 0
IF (length == 0) RETURN

len_name = LEN(name(1))
IF (len_name < 1) RETURN

pos1 = 1
DO
  DO                                   ! Remove any leading blanks
    IF (text(pos1:pos1) == ' ') THEN
      text(pos1:) = text(pos1+1:)
      length = length - 1
      CYCLE
    ELSE
      EXIT
    END IF
  END DO
  pos2 = INDEX(text(pos1:length), ' ') ! Find position of next blank
  IF (pos2 > 0) THEN
    pos2 = pos2 + pos1 - 1
  ELSE                                 ! Last name, no blank found
    pos2 = length + 1
  END IF
  number = number + 1
  nchars = MIN(len_name, pos2-pos1)
  name(number) = text(pos1:pos1+nchars-1)
  pos1 = pos2 + 1                      ! Move past the blank
  IF (pos1 > length) RETURN
END DO

RETURN
END SUBROUTINE separate_text

SUBROUTINE printc(in, cormat, dimc, ycorr, vname, yname, iopt, lout, ier)

!     Print (partial) correlations calculated using partial_corr to unit lout.
!     If IOPT = 0, print correlations with the Y-variable only.

USE lsq

IMPLICIT NONE
INTEGER, INTENT(IN)                          :: in, dimc, iopt, lout
INTEGER, INTENT(OUT)                         :: ier
REAL (dp), DIMENSION(:), INTENT(IN)          :: cormat, ycorr
CHARACTER (LEN=*), DIMENSION(0:), INTENT(IN) :: vname
CHARACTER (LEN=*), INTENT(IN)                :: yname

!     Local variables.

INTEGER            :: nrows, j1, j2, i1, i2, row, upos, tpos, last
CHARACTER (LEN=74) :: text
CHARACTER (LEN= 9) :: char1 = ' 1.0     '

!     Check validity of arguments

ier = 0
IF (in .GE. ncol) ier = 1
IF (ncol .LE. 1) ier = ier + 2
nrows = ncol - in
IF (dimc .LE. nrows*(nrows-1)/2) ier = ier + 4
IF (ier .NE. 0) RETURN

!     If iopt.NE.0 output heading

IF (iopt .EQ. 0) GO TO 30
WRITE(lout, 900)
900 FORMAT(/'     ', 'Correlation matrix')
j1 = in + 1

DO
  j2 = MIN(j1+6, ncol)
  i1 = j1 - in
  i2 = j2 - in
  WRITE(lout, 910) vname(vorder(j1:j2))
  910 FORMAT('           ', 7(a8, ' '))

!     Print correlations for rows 1 to i2, columns i1 to i2.

  DO row = 1, i2
    text = ' ' // vname(vorder(row+in))
    IF (i1 .GT. row) THEN
      upos = (row-1) * (nrows+nrows-row) /2 + (i1-row)
      last = upos + i2 - i1
      WRITE(text(12:74), '(7(F8.5, " "))') cormat(upos:last)
    ELSE
      upos = (row-1) * (nrows+nrows-row) /2 + 1
      tpos = 12 + 9*(row-i1)
      text(tpos:tpos+8) = char1
      last = upos + i2 - row - 1
      IF (row .LT. i2) WRITE(text(tpos+9:74), '(6(F8.5, " "))') cormat(upos:last)
    END IF
    WRITE(lout, '(a)') text
  END DO ! row = 1, i2

!     Move onto the next block of columns.

  j1 = j2 + 1
  IF (j1 .GT. ncol) EXIT
END DO

!     Correlations with the Y-variable.

30 WRITE(lout, 920) yname
   920 FORMAT(/'     Correlations with the dependent variable: ', a)
   j1 = in + 1
DO
  j2 = MIN(j1+7, ncol)
  WRITE(lout, 930) vname(vorder(j1:j2))
  930 FORMAT(/' ', 8(A8, ' '))
  WRITE(lout, 940) ycorr(j1:j2)
  940 FORMAT(' ', 8(F8.5, ' '))
  j1 = j2 + 1
  IF (j1 .GT. ncol) EXIT
END DO

RETURN
END SUBROUTINE printc


    integer function lcm(a,b)
    integer:: a,b
        lcm = a*b / gcd(a,b)
    end function lcm

    integer function gcd(a,b)
    integer :: a,b,t
        do while (b/=0)
            t = b
            b = mod(a,b)
            a = t
        end do
        gcd = abs(a)
    end function gcd


subroutine elemdetjm(nnode,ndime,elcod,detjm)
!-----------------------------------------------------------------------
  !****f* Domain/elmdel
! NAME
!    elmdel
! DESCRIPTION
!    This routine calculates the Cartesian derivatives cartd and detjm.
! USES
!    invmtx
! USED BY
!    nsm_elmope
!    tem_elmope
!    cdr_elmope
!    tem_exaerr
!    extnor
! SOURCE
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)  :: nnode,ndime
  real(rp),    intent(in)  :: elcod(ndime,nnode)
  real(rp),    intent(out) :: detjm
  real(rp)                 :: xjacm(ndime,ndime)
  real(rp)                 :: xjaci(ndime,ndime)

  if(ndime==2.and.nnode==3) then

     xjacm(1,1) = elcod(1,2)-elcod(1,1)
     xjacm(2,1) = elcod(2,2)-elcod(2,1)
     xjacm(1,2) = elcod(1,3)-elcod(1,1)
     xjacm(2,2) = elcod(2,3)-elcod(2,1)

     detjm=xjacm(1,1)*xjacm(2,2)-xjacm(2,1)*xjacm(1,2)

  elseif (ndime==3.and.nnode==4) then

     xjacm(1,1) = elcod(1,2)-elcod(1,1)
     xjacm(2,1) = elcod(2,2)-elcod(2,1)
     xjacm(3,1) = elcod(3,2)-elcod(3,1)
     xjacm(1,2) = elcod(1,3)-elcod(1,1)
     xjacm(2,2) = elcod(2,3)-elcod(2,1)
     xjacm(3,2) = elcod(3,3)-elcod(3,1)
     xjacm(1,3) = elcod(1,4)-elcod(1,1)
     xjacm(2,3) = elcod(2,4)-elcod(2,1)
     xjacm(3,3) = elcod(3,4)-elcod(3,1)

     xjaci(1,1)  = xjacm(2,2)*xjacm(3,3) - xjacm(3,2)*xjacm(2,3)
     xjaci(2,1)  =-xjacm(2,1)*xjacm(3,3) + xjacm(3,1)*xjacm(2,3)
     xjaci(3,1)  = xjacm(2,1)*xjacm(3,2) - xjacm(3,1)*xjacm(2,2)
     xjaci(2,2) =  xjacm(1,1)*xjacm(3,3) - xjacm(3,1)*xjacm(1,3)
     xjaci(3,2) = -xjacm(1,1)*xjacm(3,2) + xjacm(1,2)*xjacm(3,1)
     xjaci(3,3) =  xjacm(1,1)*xjacm(2,2) - xjacm(2,1)*xjacm(1,2)
     xjaci(1,2) = -xjacm(1,2)*xjacm(3,3) + xjacm(3,2)*xjacm(1,3)
     xjaci(1,3) =  xjacm(1,2)*xjacm(2,3) - xjacm(2,2)*xjacm(1,3)
     xjaci(2,3) = -xjacm(1,1)*xjacm(2,3) + xjacm(2,1)*xjacm(1,3)

     detjm = xjacm(1,1)*xjaci(1,1) + xjacm(1,2)*xjaci(2,1)+ xjacm(1,3)*xjaci(3,1)

  end if

end subroutine elemdetjm
!-----------------------------------------------------------------------
! NOTES
!
! P1 Element in 2D
! ----------------
!
! detjm=(-x1+x2)*(-y1+y3)-(-y1+y2)*(-x1+x3)
!                _                       _
!               | -y3+y2  -y1+y3   y1-y2  |
! cartd=1/detjm |                         |
!               |_ x3-x2   x1-x3  -x1+x2 _|
!
!***
!-----------------------------------------------------------------------


module mod_activation

  ! A collection of activation functions and their derivatives.

  use mod_kinds, only: ik, rk

  implicit none

  private

  public :: activation_function
  public :: gaussian, gaussian_prime, gaussian_double
  public :: relu, relu_prime, relu_double
  public :: sigmoid, sigmoid_prime, sigmoid_double
  public :: step, step_prime, step_double
  public :: tanhf, tanh_prime, tanh_double
  public :: expf, exp_prime, exp_double

  interface
    pure function activation_function(x)
      import :: rk
      real(rk), intent(in) :: x(:)
      real(rk) :: activation_function(size(x))
    end function activation_function
  end interface

contains

  pure function gaussian(x) result(res)
    ! Gaussian activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = exp(-x**2)
  end function gaussian

  pure function gaussian_prime(x) result(res)
    ! First derivative of the Gaussian activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = -2 * x * gaussian(x)
  end function gaussian_prime

  pure function gaussian_double(x) result(res)
    ! Second derivative of the Gaussian activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = -2 * gaussian(x) -2 * x * gaussian_prime(x)
  end function gaussian_double

  pure function relu(x) result(res)
    !! REctified Linear Unit (RELU) activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = max(0., x)
  end function relu

  pure function relu_prime(x) result(res)
    ! First derivative of the REctified Linear Unit (RELU) activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    where (x > 0)
      res = 1
    elsewhere
      res = 0
    end where
  end function relu_prime

  pure function relu_double(x) result(res)
    ! Second derivative of the REctified Linear Unit (RELU) activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = 0
  end function relu_double

  pure function sigmoid(x) result(res)
    ! Sigmoid activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = 1 / (1 + exp(-x))
  end function sigmoid

  pure function sigmoid_prime(x) result(res)
    ! First derivative of the sigmoid activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = sigmoid(x) * (1 - sigmoid(x))
  end function sigmoid_prime

  pure function sigmoid_double(x) result(res)
    ! Second derivative of the sigmoid activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = sigmoid(x) * (1 - sigmoid(x))**2 - sigmoid(x)**2 * (1 - sigmoid(x))
  end function sigmoid_double

  pure function step(x) result(res)
    ! Step activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    where (x > 0)
      res = 1
    elsewhere
      res = 0
    end where
  end function step

  pure function step_prime(x) result(res)
    ! First derivative of the step activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = 0
  end function step_prime

  pure function step_double(x) result(res)
    ! Second derivative of the step activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = 0
  end function step_double

  pure function tanhf(x) result(res)
    ! Tangent hyperbolic activation function.
    ! Same as the intrinsic tanh, but must be
    ! defined here so that we can use procedure
    ! pointer with it.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = tanh(x)
  end function tanhf

  pure function tanh_prime(x) result(res)
    ! First derivative of the tanh activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = 1 - tanh(x)**2
  end function tanh_prime

  pure function tanh_double(x) result(res)
    ! Second derivative of the tanh activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = -2 * tanh(x) * ( 1 - tanh(x)**2 )
  end function tanh_double

  pure function expf(x) result(res)
    ! Exponential activation function.
    ! Same as the intrinsic exp, but must be
    ! defined here so that we can use procedure
    ! pointer with it.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = exp(x)
  end function expf

  pure function exp_prime(x) result(res)
    ! First derivative of the exp activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = exp(x)
  end function exp_prime

  pure function exp_double(x) result(res)
    ! Second derivative of the exp activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = exp(x)
  end function exp_double

end module mod_activation


!This is a simple test program
!written to do I donot know what
PROGRAM Triangle_Area

  IMPLICIT NONE

  TYPE triangle
     REAL :: a, b, c
  END TYPE triangle

  TYPE(triangle) :: t

  PRINT*, 'Welcome, please enter the lengths of the 3 sides.'
  READ*, t%a, t%b, t%c
  PRINT*,'Triangle''s area: ',Area(t)

CONTAINS

  FUNCTION Area(tri)

    IMPLICIT NONE

    REAL :: Area       ! function type
    TYPE(triangle), INTENT( IN ) :: tri
    REAL :: theta, height
    ! Is this comment recognized???

    theta  = ACOS( (tri%a**2 + tri%b**2 - tri%c**2) / (2.0*tri%a*tri%b) )
    height = tri%a*SIN(theta); Area = 0.5*tri%b*height

  END FUNCTION Area

END PROGRAM Triangle_Area
!This ends the program


! Implemented by Anant Dixit (Nov. 2014)
program circles
implicit none
double precision :: P1(2), P2(2), R

P1 = (/0.1234d0, 0.9876d0/)
P2 = (/0.8765d0,0.2345d0/)
R = 2.0d0
call print_centers(P1,P2,R)

P1 = (/0.0d0, 2.0d0/)
P2 = (/0.0d0,0.0d0/)
R = 1.0d0
call print_centers(P1,P2,R)

P1 = (/0.1234d0, 0.9876d0/)
P2 = (/0.1234d0, 0.9876d0/)
R = 2.0d0
call print_centers(P1,P2,R)

P1 = (/0.1234d0, 0.9876d0/)
P2 = (/0.8765d0, 0.2345d0/)
R = 0.5d0
call print_centers(P1,P2,R)

P1 = (/0.1234d0, 0.9876d0/)
P2 = (/0.1234d0, 0.9876d0/)
R = 0.0d0
call print_centers(P1,P2,R)
end program circles

subroutine print_centers(P1,P2,R)
implicit none
double precision :: P1(2), P2(2), R, Center(2,2)
integer :: Res
call test_inputs(P1,P2,R,Res)
write(*,*)
write(*,'(A10,F7.4,A1,F7.4)') 'Point1  : ', P1(1), ' ', P1(2)
write(*,'(A10,F7.4,A1,F7.4)') 'Point2  : ', P2(1), ' ', P2(2)
write(*,'(A10,F7.4)') 'Radius  : ', R
if(Res.eq.1) then
  write(*,*) 'Same point because P1=P2 and r=0.'
elseif(Res.eq.2) then
  write(*,*) 'No circles can be drawn because r=0.'
elseif(Res.eq.3) then
  write(*,*) 'Infinite circles because P1=P2 for non-zero radius.'
elseif(Res.eq.4) then
  write(*,*) 'No circles with given r can be drawn because points are far apart.'
elseif(Res.eq.0) then
  call find_center(P1,P2,R,Center)
  if(Center(1,1).eq.Center(2,1) .and. Center(1,2).eq.Center(2,2)) then
    write(*,*) 'Points lie on the diameter. A single circle can be drawn.'
    write(*,'(A10,F7.4,A1,F7.4)') 'Center  : ', Center(1,1), ' ', Center(1,2)
  else
    write(*,*) 'Two distinct circles found.'
    write(*,'(A10,F7.4,A1,F7.4)') 'Center1 : ', Center(1,1), ' ', Center(1,2)
    write(*,'(A10,F7.4,A1,F7.4)') 'Center2 : ', Center(2,1), ' ', Center(2,2)
  end if
elseif(Res.lt.0) then
  write(*,*) 'Incorrect value for r.'
end if
write(*,*)
end subroutine print_centers

subroutine test_inputs(P1,P2,R,Res)
implicit none
double precision :: P1(2), P2(2), R, dist
integer :: Res
if(R.lt.0.0d0) then
  Res = -1
  return
elseif(R.eq.0.0d0 .and. P1(1).eq.P2(1) .and. P1(2).eq.P2(2)) then
  Res = 1
  return
elseif(R.eq.0.0d0) then
  Res = 2
  return
elseif(P1(1).eq.P2(1) .and. P1(2).eq.P2(2)) then
  Res = 3
  return
else
  dist = sqrt( (P1(1)-P2(1))**2 + (P1(2)-P2(2))**2 )
  if(dist.gt.2.0d0*R) then
    Res = 4
    return
  else
    Res = 0
    return
  end if
end if
end subroutine test_inputs

subroutine find_center(P1,P2,R,Center)
implicit none
double precision :: P1(2), P2(2), MP(2), Center(2,2), R, dm
MP = (P1+P2)/2.0d0
dm = sqrt( (P1(1)-P2(1))**2 + (P1(2)-P2(2))**2 )

Center(1,1) = MP(1) + sqrt(R**2 - (dm/2.0d0)**2)*(P2(2)-P1(2))/dm
Center(1,2) = MP(2) + sqrt(R**2 - (dm/2.0d0)**2)*(P2(1)-P1(1))/dm

Center(2,1) = MP(1) - sqrt(R**2 - (dm/2.0d0)**2)*(P2(2)-P1(2))/dm
Center(2,2) = MP(2) - sqrt(R**2 - (dm/2.0d0)**2)*(P2(1)-P1(1))/dm
end subroutine find_center


module SanitizedStatistics
    implicit none

    integer,parameter,private   :: dp = kind(1.d0)

    interface pcor
        procedure   :: pcor1D
        procedure   :: pcor2D
    end interface

    contains

    ! Normal distribution via
    ! Marsaglia polar method
    function normal(mean,std) result(x)
        implicit none

        real(dp),intent(in) :: mean,std
        real(dp)            :: x

        real(dp)            :: u,v,s
        real(dp)            :: r1,r2

        logical             :: cont

        cont = .true.
        do while(cont)
            call random_number(r1)
            call random_number(r2)
            u = r1*2.0 - 1.0
            v = r2*2.0 - 1.0
            s = u*u + v*v

            cont = (s .ge. 1.0) .or. (s .le. 0.0)
        end do

        s = u*sqrt(-2.0*log(s)/s)
        x = mean + std*s
    end function

    ! Welford's online algorithm
    ! xb = <x>
    ! s = var(x)
    subroutine Welford(x,xb,s)
        implicit none

            real,intent(in)     :: x(:)
            real,intent(out)    :: xb
            real,intent(out)    :: s

            real    :: lxb,Delta
            integer :: n

            xb = 0
            Delta = 0
            do n = 1,size(x)
                lxb = xb
                xb = lxb + (x(n)-lxb)/n
                Delta = Delta + (x(n)-lxb)*(x(n)-xb)
            end do
            s = Delta/(n-1)
    end subroutine

    ! Draw random integer between mi and ma
    function randint(mi,ma) result(x)
        implicit none

        integer,intent(in)  :: mi,ma
        integer             :: x
        real    :: r

        call random_number(r)
        x = mi + floor(r*(ma-mi+1))
    end function

    ! Pearson correlation coefficient between
    ! two matrices
    function pcor2D(X,Y) result(r)
        implicit none

        real,intent(in) :: X(:,:),Y(:,:)
        real            :: r

        real    :: x_av,y_av
        real    :: xx,yy,xy
        integer :: Nx,Ny,N, i,j

        Ny = size(X,1)
        Nx = size(X,2)
        N = Nx*Ny

        x_av = 0.0
        y_av = 0.0
        do j = 1,Nx
        do i = 1,Ny
            x_av = x_av + x(i,j)
            y_av = y_av + y(i,j)
        end do
        end do
        x_av = x_av/N
        y_av = y_av/N

        xy = 0.0
        xx = 0.0
        yy = 0.0
        do j = 1,Nx
        do i = 1,Ny
            xy = xy + x(i,j)*y(i,j)
            xx = xx + x(i,j)*x(i,j)
            yy = yy + y(i,j)*y(i,j)
        end do
        end do

        r = (xy - N*x_av*y_av)/sqrt((xx-N*x_av*x_av)*(yy-N*y_av*y_av))
    end function

    ! Pearson correlation coefficient between
    ! two vectors
    function pcor1D(x,y) result(r)
        implicit none

        real,intent(in) :: x(:),y(:)
        real            :: r

        real    :: x_av,y_av
        real    :: xx,yy,xy
        integer :: N, i

        N = size(x,1)

        x_av = 0.0
        y_av = 0.0
        do i = 1,N
            x_av = x_av + x(i)
            y_av = y_av + y(i)
        end do
        x_av = x_av/N
        y_av = y_av/N

        xy = 0.0
        xx = 0.0
        yy = 0.0
        do i = 1,N
            xy = xy + x(i)*y(i)
            xx = xx + x(i)*x(i)
            yy = yy + y(i)*y(i)
        end do

        r = (xy - N*x_av*y_av)/sqrt((xx-N*x_av*x_av)*(yy-N*y_av*y_av))
    end function

end module


SUBROUTINE vecuni(n,v,modul)
!*****************************************************************************
! This routine compute de length of the vector v and converts it to a unit one
!*****************************************************************************
IMPLICIT NONE

  !--- Dummy variables
  INTEGER(kind=4),INTENT(IN):: n     !Vector dimension
  REAL(kind=8),INTENT(INOUT):: v(n)  !Vector
  REAL(kind=8),INTENT(OUT):: modul   !Module of input vector

  modul = SQRT(DOT_PRODUCT(v(1:n),v(1:n)))
  IF (modul > 0d0) v(1:n)=v(1:n)/modul

RETURN
END SUBROUTINE vecuni


program main

        use ISO_FORTRAN_ENV

        integer (int64) :: primec, i

        i = 1
        primec = 0

        do
                if(isprime(i)) then
                        primec = primec + 1
                endif

                if(primec == 10001) then
                        exit
                endif

                i = i + 1

        end do

        print*, i

contains

        function isprime (s)
                logical :: isprime
                integer (kind=8) :: s, i, top

                isprime = .false.

                if(s <= 1) then
                        return
                end if

                top = int(sqrt(real(s))) + 1

                do i = 2, top + 1, 1

                        if (i == top) then
                                isprime = .true.
                                exit
                        end if

                        if(mod(s, i) == 0) then
                                exit
                        end if

                end do

                return

        end function isprime

end program main


module quad_glegq

    ! precision specification
    use preci, wp => dp

    ! external functions and subroutines
    use funcs

    implicit none

    ! used for sharing between QUAD and GLEGQ
    real (wp) :: X,Y,C,VAR,NVAR

contains

    function QUAD(GLEGQ,N,FX,A,B)
!*******************************************************************
! THE DOUBLE PRECISION function SUBPROGRAM APPROXIMATES  THE VALUE OF
! AN INTEGRAL I(FX,A,B) OF A function FX(X) OVER THE INTERVAL (A,B)
! USING A QUADRATURE RULE WHICH IS SPECIFIED BY THE PARAMETERS METHOD
! AND N.
!
!
! CALLING SEQUENCE: APPROX= QUAD(METHOD,N,FX,A,B)
!
!
!  PARAMETRS:
! ON ENTRY:
!        METHOD-DOUBLE PRECISION subroutine METHOD(N,A,B,P,W)
!            USED TO SPECIFY THE TYPE OF QUADRATURE RULE TO BE
!            USED AND TO OBTAIN THE APPROPRIATE POINTS AND WEIGHTS
!             =NCQ- NEWTON-COTES RULES,
!              GLFGQ-GAUSS-LEGENDRE RULES,
!              GLAGQ-GAUSS-LAGUERRE RULES.E
!       N -   INTEGER
!             THE NUMBER OF QUADRATURE   POINTS TO BE USED.   LIMITS
!             ON N WHEN METHOD= NCQ  : 1 <= N <= 21,
!                               GLEGQ: 2 <=N  <=20,
!                               GLAG : 2<= N  <=10,
!       FX -  DOUBLE  PRECISION function FX(X)
!             USED FOR EVALUATING THE INTEGRAND.
!      A,B- REAL*8
!            THE LEFT AND RIGHT ENDPOINTS OF THE INTERVAL OF
!                  INTEGRATION.
!
!   ON RETURN:
!           QUAD - REAL*8
!            THE APPROXIMATE VALUE OF  I(FX,A,B).
!          SAMPLE CALLING PROGRAM:
!    C********** THIS PROGRAM APPROXIMATES THE VALUE OF I(FX,A,B) USING A
!    C           COMPOSITE 5-POINT GAUSS-LEGENDRE RULE. THE NUMBER OF
!    C          SUBDIVISIONS OF (A,B) IS MDIV.
!               IMPLICIT REAL*8 (A-H,O-Z)
!               EXTERNAL    FX,GLEGO
!              READ (5,*) A,B,MDIV
!              H=(B-A)/MDIV
!              XL=A
!              XR=A+H
!              APPROX=0.DO
!              do IDIV=1,MDIV
!              APPROX=APPROX+QUAD(GLEGQ,5,FX,XL,XR)
!               XL=XR
!               XR=XR +H
!            10 CONTINUE
!
!              write(6,*) 'APPROX. VALUE OF THE INTEGRAL=',APPROX
!              stop
!               end
!
!            function FX(X)
!             IMPLICIT REAL*8 (A-H,O-Z)
!              FX = .... FORMULA TO EVALUATE THE INTEGRAND...
!              return
!              end
!
!    REFERENCE : ELEMENTARY NUMERICAL ANALYSIS
!                BY CONTE AND DEBOOR
!                PAGE 299-306
!*******************************************************************
    real (wp) :: A, B, D, DT2, FX, SU
    integer :: N, ND2, NJ, NSTART, NSTJ
    real (wp), dimension(20) :: P,W
    real (wp) :: QUAD
    external FX,GLEGQ

    ! local variable for indexing
    integer :: iq ! appended with "q", which is the first letter of QUAD
!
!
!       **********************************************************
!       *
!       * RETRIEVE POINT AND WEIGHTS, TRANSFORMED INTO THE SPECIFIED
!       *  INTEPVAL (A,B), FROM THE subroutine METHOD, AND APPLY THE
!       *  QUADRATURE FORMULA.
!       *
!       *
!       **********************************************************
!
    call GLEGQ (N, A, B, P, W)
    SU = 0.D0
    do iq=1,N
        SU = SU + W(iq) * FX(P(iq))
    end do
    QUAD=SU
    return
    end function QUAD

!**************************************************************************

    subroutine GLEGQ( N, A, B, P, W)
!**************************************************************************
!   THIS DOUBLE PRECISION subroutine IS DESIGNED TO BE USED BY EITHER OF
!   THE ROUTINES QUAD OR ADQUAD FOR APPROXIMATING THE VALUE OF THE
!   DEFINITE INTEGRAL I(FX,A,B) OF FX(X) OVER THE INTERVAL (A,B) USING AN
!   N-POINT GAUSS-LEGENDRE FORMULA.
!
!   THE PURPOSE OF GLEGQ IS TO SUPPLY, TO QUAD OR ADQUAD, THE N QUADRA-
!   TURE POINTS AND CORRESPONDING WEIGHTS FOR THE SPECIFIED N-POINT
!   FORMULA FOR THE GIVEN INTERVAL OF INTEGRATION.  THIS IS DONE BY
!   TAKING THE POINTS AND WEIGHTS FOR THE "NORMALIZED" INTERVAL (-1,1)
!   AND TRANSFORMING THEM TO (A,B).
!
!   THIS ROUTINE CAN ALSO BE USED BY THE ROUTINE QUADM TO GENERATE
!   ROUTINE GAUSS-LEGENDRE RULES FOR APPROXIMATING INTEGRALS IN M DIMEN-
!   SIONS, M=2, 3.
!
!
!   CALLING SEQUENCE: call GLEGQ(N,A,B,P,W)
!
!   PARAMETERS:
!   ON ENTRY:
!        N    -INTEGER
!               THE NUMBER OF QUADRATURE POINTS TO BE USED.  2<=N<=20
!        A, B -REAL*8
!               THE LEFT AND RIGHT ENDPOINTS OF THE INTERVAL OF
!               INTEGRATION.
!
!   ON RETURN:
!        P    -REAL*8(N)
!               THE POINTS FOR THE N-POINT GUASS-LEGENDRE QUADRATURE
!               RULE ON THE INTERVAL (A,B).
!        W    -REAL*8(N)
!               THE WEIGHTS FOR THE N-POINT GAUSS-LEGENDRE QUADRATURE
!               RULE ON THE INTERVAL (A,B).
!
!
!   SAMPLE CALLING PROGRAM:
!        IMPLICIT REAL*8 (A-H,O-Z)
!        EXTERNAL FX,GLEGQ
!        read(5,*) A,B,N
!        APPROX=QUAD(GLEGQ,FX,N,A,B)
!        write(6,*) 'THE',N,'-POINT GAUSS-LEGENDRE QUADRATURE APPROX.='
!       +           ,APPROX
!        stop
!        end
!
!        function FX(X)
!        IMPLICIT REAL*8 (A-H,O-Z)
!        FX=... FORMULA TO EVALUATE THE INTEGRAND...
!        return
!        end
!**************************************************************************
    real (wp) :: A, B, D, DT2
    integer :: N, ND2, NJ, NSTART, NSTJ
    real (wp), dimension(100) :: PT, WT
    real (wp), dimension(9) :: WZ
    real (wp), dimension(N) :: P, W

    ! local variable for indexing
    integer :: jg ! appended with "g", which is the first letter of GLEGQ

!  *******************
!  *
!  * THE VECTOR PT CONTAINS THE LOCATION OF THE NEGATIVE POINTS IN
!  * (-1,1) USED IN THE FORMULA. if N IS EVEN, THE ONLY OTHER POINTS
!  * ARE POSITIVE MIRROR IMAGES OF THE NEGATIVES. FOR N ODD, THERE IS AN
!  * ADDITIONAL POINT AT THE ORIGIN.
!  *
!  *******************

    DATA PT( 1),PT( 2),PT( 3),PT( 4),PT( 5),PT( 6),PT( 7),PT( 8), &
    PT( 9),PT( 10)/-5.773502691896259D-01,-7.745966692414834D-01, &
    -8.611363115940526D-01,-3.399810435848563D-01, &
    -9.061798459386640D-01,-5.384693101056832D-01, &
    -9.324695142031520D-01,-6.612093864662646D-01, &
    -2.386191860831969D-01,-9.491079123427586D-01/
    DATA PT(11),PT(12),PT(13),PT(14),PT(15),PT(16),PT(17),PT(18), &
    PT(19),PT( 20)/-7.415311855993942D-01,-4.058451513773972D-01, &
    -9.602898564975362D-01,-7.966664774136267D-01, &
    -5.255324099163290D-01,-1.834346424956498D-01, &
    -9.681602395076261D-01,-8.360311073266358D-01, &
    -6.133714327005905D-01,-3.242534234038089D-01/
    DATA PT(21),PT(22),PT(23),PT(24),PT(25),PT(26),PT(27),PT(28), &
    PT(29),PT( 30)/-9.739065285171717D-01,-8.650633666889845D-01, &
    -6.794095682990245D-01,-4.333953941292472D-01, &
    -1.488743389816312D-01,-9.782286581460570D-01, &
    -8.870625997680954D-01,-7.301520055740493D-01, &
    -5.190961292068119D-01,-2.695431559523450D-01/
    DATA PT(31),PT(32),PT(33),PT(34),PT(35),PT(36),PT(37),PT(38), &
    PT(39),PT( 40)/-9.815606342467190D-01,-9.041172563704749D-01, &
    -7.699026741943046D-01,-5.873179542866175D-01, &
    -3.678314989981802D-01,-1.252334085114689D-01, &
    -9.841830547185882D-01,-9.175983992229781D-01, &
    -8.015780907333099D-01,-6.423493394403403D-01/
    DATA PT(41),PT(42),PT(43),PT(44),PT(45),PT(46),PT(47),PT(48), &
    PT(49),PT( 50)/-4.484927510364468D-01,-2.304583159551348D-01, &
    -9.862838086968123D-01,-9.284348836635734D-01, &
    -8.272013150697650D-01,-6.872929048116856D-01, &
    -5.152486363581541D-01,-3.191123689278898D-01, &
    -1.080549487073437D-01,-9.879925180204854D-01/
    DATA PT(51),PT(52),PT(53),PT(54),PT(55),PT(56),PT(57),PT(58), &
    PT(59),PT( 60)/-9.372733924007058D-01,-8.482065834104270D-01, &
    -7.244177313601699D-01,-5.709721726085388D-01, &
    -3.941513470775634D-01,-2.011940939974345D-01, &
    -9.894009349916499D-01,-9.445750230732326D-01, &
    -8.656312023878317D-01,-7.554044083550030D-01/
    DATA PT(61),PT(62),PT(63),PT(64),PT(65),PT(66),PT(67),PT(68), &
    PT(69),PT( 70)/-6.178762444026438D-01,-4.580167776572274D-01, &
    -2.816035507792589D-01,-9.501250983763744D-02, &
    -9.905754753144173D-01,-9.506755217687678D-01, &
    -8.802391537269859D-01,-7.815140038968014D-01, &
    -6.576711592166909D-01,-5.126905370864771D-01/
    DATA PT(71),PT(72),PT(73),PT(74),PT(75),PT(76),PT(77),PT(78), &
    PT(79),PT( 80)/-3.512317634538763D-01,-1.784841814958478D-01, &
    -9.915651684209309D-01,-9.558239495713978D-01, &
    -8.926024664975557D-01,-8.037049589725230D-01, &
    -6.916870430603533D-01,-5.597708310739476D-01,                       &
    -4.11751161462826D-01,-2.518862256915055D-01/
    DATA PT(81),PT(82),PT(83),PT(84),PT(85),PT(86),PT(87),PT(88), &
    PT(89),PT(90)/-8.477501304173527D-02,-9.924068438435845D-01, &
    -9.602081521348301D-01,-9.031559036148179D-01, &
    -8.227146565371427D-01,-7.209661773352294D-01, &
    -6.005453046616811D-01,-4.645707413759609D-01, &
    -3.165640999636298D-01,-1.603586456402254D-01/
    DATA PT(91),PT(92),PT(93),PT(94),PT(95),PT(96),PT(97),PT(98), &
    PT(99),PT(100)/-9.931285991850949D-01,-9.639719272779138D-01, &
    -9.122344282513259D-01,-8.391169718222189D-01, &
    -7.463319064601507D-01,-6.360536807265151D-01, &
    -5.108670019508271D-01,-3.737060887154196D-01, &
    -2.277858511416451D-01,-7.652652113349732D-02/
!
!  ***************
!  *
!  * WT CONTAINS THE WEIGHTS FOR THE VALUES IN PT; THE SAME WEIGHTS ARE
!  * ALSO USED FOR THE 'MIRROR IMAGE' POINTS.
!  *
!  ***************
!
    DATA WT(1),WT(2),WT(3),WT(4),WT(5),WT(6),WT(7),WT(8), &
    WT(9),WT(10)/ 1.000000000000000D00,5.555555555555557D-01, &
    &    3.478548451374538D-01,6.521451548625462D-01, &
    &    2.369268850561891D-01,4.786286704993665D-01, &
    &    1.713244923791703D-01,3.607615730481386D-01, &
    &    4.679139345726910D-01,1.294849661688697D-01/
    DATA WT(11),WT(12),WT(13),WT(14),WT(15),WT(16),WT(17),WT(18), &
    WT(19),WT(20)/ 2.797053914892767D-01,3.8183005050501189D-01, &
    &    1.012285362903762D-01,2.223810344533745D-01, &
    &    3.137066458778873D-01,3.626837833783620D-01, &
    &    8.127438836157441D-02,1.806481606948574D-01, &
    &    2.606106964029355D-01,3.123470770400028D-01/
    DATA WT(21),WT(22),WT(23),WT(24),WT(25),WT(26),WT(27),WT(28), &
    WT(29),WT(30)/ 6.667134430868812D-02, 1.494513491505806D-01, &
    &    2.190863625159820D-01,2.692667193099964D-01, &
    &    2.955242247147529D-01,5.566856711617367D-02, &
    &    1.255803694649046D-01,1.862902109277342D-01, &
    &    2.331937645919905D-01,2.628045445102467D-01/
    DATA WT(31),WT(32),WT(33),WT(34),WT(35),WT(36),WT(37),WT(38), &
    WT(39),WT(40)/ 4.717533638751183D-02,1.069393259953184D-01, &
    &    1.600783285433462D-02,2.031674267230659D-01, &
    &    2.334925365383548D-01,2.491470458134028D-01, &
    &    4.048400476531588D-02,9.212149983772845D-02, &
    &    1.388735102197872D-02,1.781459807619457D-01/
    DATA WT(41),WT(42),WT(43),WT(44),WT(45),WT(46),WT(47),WT(48), &
    WT(49),WT(50)/ 2.078160475368885D-01,2.262831802628972D-01, &
    &    3.511946033175186D-02,8.015808715976020D-02, &
    &    1.215185706879032D-02,1.572031671581935D-01, &
    &    1.855383974779378D-01,2.051984637212956D-01, &
    &    2.152638534631578D-01,3.075324199611727D-02/
    DATA WT(51),WT(52),WT(53),WT(54),WT(55),WT(56),WT(57),WT(58), &
    WT(59),WT(60)/ 7.036604748810809D-02,1.071592204671719D-01, &
    &    1.395706779261543D-01,1.662692058169939D-01, &
    &    1.861610000155622D-01,1.984314853271116D-01, &
    &    2.715245941175409D-02,6.225352393864789D-02, &
    &    9.515851168249277D-02,1.246289712555339D-01/
    DATA WT(61),WT(62),WT(63),WT(64),WT(65),WT(66),WT(67),WT(68), &
    WT(69),WT(70)/ 1.495959888165767D-01, 1.691565193950025D-01, &
    &     1.826034150449236D-01, 1.894506104550685D-01, &
    &     2.414830286854793D-02, 5.545952937398720D-02, &
    &     8.503614831717917D-02, 1.118838471934040D-01, &
    &     1.351363684685255D-01, 1.540457610768103D-01/
    DATA WT(71),WT(72),WT(73),WT(74),WT(75),WT(76),WT(77),WT(78), &
    WT(79),WT(80)/ 1.680041021564500D-01, 1.765627053669926D-01, &
    &     2.161601352648331D-02, 4.971454889496981D-02, &
    &     7.642573025488905D-02, 1.009420441062872D-01, &
    &     1.225552067114785D-01, 1.406429146706506D-01, &
    &     1.546846751262652D-01, 1.642764837458327D-01/
    DATA WT(81),WT(82),WT(83),WT(84),WT(85),WT(86),WT(87),WT(88), &
    WT(89),WT(90)/ 1.691423829631436D-01, 1.946178822972648D-02, &
    &     4.481422676569960D-02, 6.904454273764122D-02, &
    &     9.149002162244999D-02, 1.115666455473340D-01, &
    &     1.287539625393362D-01, 1.426067021736066D-01, &
    &     1.527660420658597D-01, 1.589688433939543D-01/
    DATA WT(91),WT(92),WT(93),WT(94),WT(95),WT(96),WT(97),WT(98), &
    WT(99),WT(100)/ 1.761400713915212D-02, 4.060142980038694D-02, &
    &     6.267204833410905D-02, 8.327674157670474D-02, &
    &     1.019301198172404D-01, 1.181945319615184D-01, &
    &     1.316886384491766D-01, 1.420961093183820D-01, &
    &     1.491729864726037D-01, 1.527533871307258D-01/
!
!  ***************
!  *
!  * WZ CONTAINS ALL THE WEIGHTS FOR THE ORIGIN.
!  *
!  ***************
!
    DATA WZ/ 8.888888888888890D-01, 5.688888888888889D-01, &
    &     4.179591836734694D-01, 3.302393550012598D-01, &
    &     2.729250867779006D-01, 2.325515532308739D-01, &
    &     2.025782419255613D-01, 1.794464703562065D-01, &
    &     1.610544498487837D-01/
!
!
!  ***************
!  *
!  * NSTART INDICATES WHERE THE DESIRED POINTS AND WEIGHTS ARE LOCATED
!  * RETRIEVE THE POINTS AND WEIGHES. TRANSFORM THE POINTS TO (A,B).
!  *
!  ***************
!
    NSTART = ((N/2)*((N-1)/2))
    ND2 = N/2
    C = (B - A)/2.0D0
    D = (B + A)/2.0D0
    DT2 = D*2
    do jg=1,ND2
        NJ = N-jg+1
        NSTJ  = NSTART + jg
        P(jg)  = PT(NSTJ)*C +D
        P(NJ) = -P(jg) + DT2
        W(jg)  = WT(NSTJ)*C
        W(NJ) = W(jg)
    end do
    if ((ND2)*2 /= N) then
        P(ND2 + 1) = D
        W(ND2 + 1) = WZ(ND2)*C
    end if
    return
    end subroutine glegq

end module quad_glegq


subroutine mbmatb(a,b,c,n1,n2,n3)

!-----------------------------------------------------------------------
!
! This routine evaluates the matrix product A = Bt C, where
! A -> Mat(n1,n2), B -> Mat(n3,n1), C -> Mat(n3,n2)
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip) :: n1,n2,n3,i,j,k
  real(rp)    :: a(n1,n2), b(n3,n1), c(n3,n2)

  do i=1,n1
     do j=1,n2
        a(i,j)=0.0_rp
        do k=1,n3
           a(i,j)=a(i,j)+b(k,i)*c(k,j)
        end do
     end do
  end do

end subroutine mbmatb


!Program to test SCALE intrinsic function.

program test_scale
  call test_real4 (3.0, 2)
  call test_real4 (33.0, -2)
  call test_real4 (-3., 2)
  call test_real4 (0., 3)
  call test_real8 (0._8, 3)
  call test_real8 (3.0_8, 4)
  call test_real8 (33.0_8, -4)
  call test_real8 (-33._8, 4)
end
subroutine test_real4 (orig, i)
  real x,y,orig
  integer i
  x = orig
  y = x * (2.0 ** i)
  x = scale (x, i)
  if (abs (x - y) .gt. abs(x * 1e-6)) call abort
end

subroutine test_real8 (orig, i)
  real*8 x,y,orig
  integer i
  x = orig
  y = x * (2.0 ** i)
  x = scale (x, i)
  if (abs (x - y) .gt. abs(x * 1e-6)) call abort
end


c  *********************************************************************
c  *                                                                   *
c  *               F U N C T I O N       D A Y H O U R S               *
c  *                                                     de   11/07/17 *
c  *********************************************************************
c  This function uses latitude, zenith angle, declination of the sun and
c  month, day and year to calculate the daylength for a day. The code was
c  was provided by Simon van Donk and the reference he used is found in
c  Keisling, T.C., 1982. Calculation of the length of day. Agron. J.
c  74:758-759.

!  INPUTS:  list variables here with C and R for each variable

!  OUTPUTS: list variables here with C and R for each variable

      FUNCTION dayhours(latitude, day, month, year)
      IMPLICIT NONE

!     Variable declarations
      REAL :: dayhours, latitude
      INTEGER :: year

!     Local variables
      REAL :: declin, degtorad, julday, lambda, sunanom, sunbelow
      REAL :: zenith
      REAL :: day, month

!Initialize local variables
      declin = 0.0
      lambda = 0.0
      sunanom = 0.0
      sunbelow = 0.0
      zenith = 0.0
      julday = 0.0

! end of declarations

      !     + + + purpose + + +
      ! This function calculates the length of the day, in hours, for a given day

      !     + + + argument definitions + + +
      ! many of these definitions came from the Keisling reference given above.
      ! day - the day of the year for which daylength is being calculated (1-31)
      ! dayhours - the hours of daylight calculated herein and returned from this function
      ! latitude - latitude of the site, degrees (north > 0, south < 0), in degrees
      ! mon - the month of the year (1-12)
      ! year - the year

      !     + + + local variable definitions + + +
      ! declin - the declination of the sun in degrees
      ! degtorad - parameter to convert values in degrees to radians. It is equal to pi/180
      ! lambda - ???
      ! sunanom - mean anomaly of the sun in degrees. This is M in Keisling ref.
      ! sunbelow - the angle of the sun below the horizon. This is variable B in Keisling ref.
      ! zenith - the zenithal distance of the sun at the event of interest in degrees

      ! calculate the Julian day
      julday = Day-32 + (Int(275*(Month/9))) + (2*Int(3/(Month+1))) +
     c (Int((Month/100)-(Mod(Year,4)/4)+0.975))

!     Calculate M use variable sunanom for M
      sunanom = 0.985600 * julday - 3.251

!     Calculate the lambda value
      lambda = sunanom + 1.916 * sind(sunanom) + 0.020 *
     c         sind(2*sunanom) + 282.565

!     Calculate the declination of the sun (degrees)
      declin = asind(0.39779 * sind(lambda))

!     Calculate zenith angle (degrees) sunbelow is used for B
      zenith = 90 - sunbelow

!     Calculate the daylength
      dayhours = (2.0/15.0) * acosd((cosd(zenith))*(1/(cosd(latitude)))*
     c (1/(cosd(declin)))- ((tand(latitude))*(tand(declin))))

      END FUNCTION dayhours