! This program calculates the capacitance of a  tip-sample system  with cylindrical symmetry.
! The tip may consist these parts: a spherical cap, a conical shank, a disk cantilever
! The sample is a dielectric with arbitrary thickness (including zero thickness) over a conducting electrode.
! sample input file is made automatically in the first run
! Author: Ali Sadeghi, Uni Basel, 2011

!==========================================

module definitions
! variables
      implicit none
      integer , parameter :: dp=kind(1.d0)  ! double precision
      real(dp), parameter :: pi=3.141592653589793238462643383279502884197_dp
      real(dp), parameter :: e0=8.854187817620d-3 !vacuum permittivity in nN/V2
      real(dp), parameter :: pi_e0 = pi*e0 ! to make units for unitless quantities

! tip and sample parameters
      real(dp)     :: Rtip,RCant,HCone,dCant,theta
      real(dp)     :: eps_r, Hsam
! tip-sample separation: loops from s)min to d_max
      real(dp)     :: d_min,d_max,Z

! simulation parameters
      real(dp)     :: h0,rho_max,Z_max   ! finest grid spacing and simulation box size (truncation lengths)
      real(dp)     :: qn,qm,ql   ! growth factors
      integer      :: n,m,l ! number of grid points in rho and +/-z directions
      real(dp), allocatable  :: hn(:),r(:),hm(:),zm(:) ! grid-spacing and coordinates of each grid point
      real(dp), allocatable  :: u(:,:),g(:,:)  ! potential and its gradient

! Definition of the tip for Dirichlet BC
      integer , allocatable  :: ProbeBot(:), ProbeTop(:)   ! tip geometry: bottom and top
      real    , allocatable  :: b(:,:)  ! this applies BC: if b(j,i)=1 then it can vary, if =0 Dirichlet BC (fixed)
      integer      ::  nApex,nCone,nLever,nEdge
      integer      ::  js
      integer      ::  i,j,k
      real(dp)     ::  Energy,gnrm,x,y
      real(dp)     :: Er,Ez,Force  ! electric field and force
      logical      :: spheretest, leveronlytest ! for testing purpose

     integer       :: verbose=2

contains

subroutine GenerateGrid  !  __ generates  a non-uniform grid  _______________
integer Nuni ! number of points in the uniform region
real(dp) q
! growth factors are determined according to h0, # of grid-points and box sizes
! Alternatively, one can determine # according to known growth factors, h0 and box sizes
!   or even determine the box sizes according to known h0, growth factors and #
! We prefer to get h0 and box sizes as input parametersi. Then the maximum number
! of point-grids that works with the users specific machine-memory is used to find the smallest possible growth factors.

Nuni=1  !
do i=0,Nuni-1
    r(i)=h0*i
    hn(i)=h0
enddo

r(Nuni)=h0*Nuni

qn=1.012
if(verbose>1) print*,'-----------Additional information:'
if(verbose>1) print ('(a,$)'), " Suggested number of grid points (n,m+,m-): "
if(verbose>1) print ('(i5,$)'),  nint(log(1_dp+(rho_max/h0-Nuni)*(qn-1_dp))/log(qn) + Nuni)
! find the growth factor
do  qn=1._dp,1.5,1.d-4
  x=h0*(1-qn**(n-Nuni))/(1-qn)
  if(x>=rho_max - r(Nuni)) exit  ! found
enddo

hn(Nuni)=h0*(rho_max-r(Nuni))/x
r(Nuni+1)=sum(hn(0:Nuni))
do i=Nuni+2,n
  hn(i-1)=hn(i-2)*qn
  r(i)=sum(hn(0:i-1))
enddo
hn(n)=hn(n-1)*qn
!		print*,r(n);  do i=0,n; write(333,*)i,r(i),hn(i); enddo

! Z+ direction
Nuni=1
hm(1:Nuni)=h0
do j=1,Nuni ; zm(j)=h0*j ; enddo

q=1.010
    if(verbose>1) print('(i5,$)'), nint(log(1_dp+(Z_max/h0-Nuni)*(q-1_dp))/log(q)) + Nuni

do qm=1._dp,1.5_dp, 1.d-4
  x=h0*(1-qm**(m-Nuni))/(1-qm)
  if(x>=Z_max-zm(Nuni)) exit
enddo

hm(Nuni+1)=h0 * (Z_max-zm(Nuni))/x
zm(Nuni+1)=sum(hm(1:Nuni+1))
do j=Nuni+2,m
    hm(j)=hm(j-1)*qm
    zm(j)=sum(hm(1:j))
enddo

! Z- direction
hm(js:0) = h0 ! gap fiiled with h0
do j=js,0; zm(j)=h0*j; enddo

if (l+js>0) then
   q=1.02
    if(verbose>1)   print'(i5,$)', nint(log(1_dp+(Hsam/h0)*(q-1_dp))/log(q))
   do ql=1._dp,2.0_dp,1.d-4
      x=h0*(1-ql**(l+js))/(1-ql)
      if(x>=Hsam) exit
   enddo
   hm(js)=h0*Hsam/x
else
    hm(js)=h0
endif
do j=js-1,-l,-1
    hm(j)=hm(j+1)*ql
    zm(j)=-sum(hm(j+1:0))
enddo
Z=-zm(js)
!!	print*,l,m, zm(-l),zm(m);  do j=-l,m; write(333,*)j,zm(j),hm(j); enddo; stop
!!do nLever=1,n ; if(r(nLever)>=RCant) exit; enddo;
!!print '(a,F6.3,a)',  "      <<<<<<<<<<<<<<<<<<<<<<<<<<<<  Tip-Sample dist= " ,Z," nm >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
!print '(a,i10,4i5,a,3f8.4)',     " Number of points (TOTAL, n,m+,m-,gap)  "  &
!       ,(n+1)*(m+l+1) ,n,m,l+js,-js , " ;    Growth factors rho, z+, z- = " ,qn,qm,ql
if(verbose>1) then
   print '(a,i3)',     "    Additional in gap:   "  ,-js
   !print '(a, i8, a, f5.1)',"  >>> N_TOTAL: ",(n+1)*(m+l+1) , '   Approximate memory (GB): ', ((n+1)*(m+l+1))**1.5 * (8+2)*1.e-9
   print '(a, i8, a, f5.1, "GB")',"  >>>>>>>>>>>>    N_TOTAL: ",(n+1)*(m+l+1) , &
         ' ; Approximate memory needed: ', (n+1)*(m+l+1)*(min(n,m+l)+5)*8.e-9
  print '(a,3f7.4)', " Geometic increment factor for mesh spacin (r,z+,z-):" ,qn,qm,ql
endif
end subroutine GenerateGrid

!==================================================================

subroutine SetupProbe
! Note: to keep the tip-geometry fixed, Cone Height is constant and it is the sample thickness that varies by separation
real*8 Ra , Rc , Ez2
Ra=Rtip*(1._dp-sin(theta))
Rc=Rtip*cos(theta)
b(:,:) =1.0 !free-to-vary points
! Dirichlet BC for
b(-l,:)=0. ! backelectrode
b(m,:)=0.  ! and top
b(:,n)=0.  ! and side walls

! initial guess for potential: 0 everywhere else on tip
u=0._dp
! tip geometry (u(tip)=1, b(tip)=0)
if (spheretest) then
do i=0, n-1
    x=r(i)
    if (x< Rtip) then  ! sphere
      nApex=i
      y= Rtip - sqrt(Rtip**2 - x**2)
      do j=0,m ; if (zm(j) >=y ) exit; enddo ; ProbeBot(i)=j
      do j=1,m ; if (Zm(j)>= y+2*  sqrt(rtip**2 - x**2)) exit; enddo;  ProbeTop(i)=j
         b(ProbeBot(i) : ProbeTop(i),i)=0
         u(ProbeBot(i) : ProbeTop(i),i)=1
   endif
enddo

elseif (leveronlytest) then
do i=0, n-1
    x=r(i)
    if (x< RCant) then  ! Only the cantilever
     nLever=i
     y= HCone
      do j=0,m ; if (zm(j) >=y )        exit; enddo ; ProbeBot(i)=j
      do j=1,m ; if(Zm(j)>=HCone+dCant) exit; enddo;  ProbeTop(i)=j
         b(ProbeBot(i) : ProbeTop(i),i)=0
         u(ProbeBot(i) : ProbeTop(i),i)=1

    elseif (x< RCant+dCant/2 ) then  ! cantelever rounded edge
      nEdge= i
      y= HCone + dCant/2 - sqrt((dCant/2)**2 - (x-RCant)**2)
      do j=0,m ; if (zm(j) >=y ) exit; enddo ; ProbeBot(i)=j
      do j=1,m ; if (Zm(j)>= y+2*  sqrt((dCant/2)**2 - (x-RCant)**2)) exit; enddo;  ProbeTop(i)=j
      !do j=1,m ; if(Zm(j)>=HCone+dCant) exit; enddo;  ProbeTop(i)=j
         b(ProbeBot(i) : ProbeTop(i),i)=0
         u(ProbeBot(i) : ProbeTop(i),i)=1
   endif
enddo

else
 ! if it is not a sphere test, make tip geometry
do j=1,m ; if(Zm(j)>=HCone+dCant) exit; enddo;  ProbeTop(:)=j

!  make the tip geometry
do i=0, n-1
   x=r(i)
   if(x< Rc) then  ! sphere
     nApex=i
     y=Rtip-sqrt(Rtip**2-x**2)
     do j=0,m ; if (zm(j) >=y )        exit; enddo ; ProbeBot(i)=j
     do j=1,m ; if(Zm(j)>=HCone+dCant) exit; enddo;  ProbeTop(i)=j
         b(ProbeBot(i) : ProbeTop(i),i)=0
         u(ProbeBot(i) : ProbeTop(i),i)=1

   elseif (x< (HCone-Ra)*tan(theta)+Rc )  then  ! cone
      nCone=i
      y= (x-Rc)/tan(theta)+Ra
      do j=0,m ; if (zm(j) >=y )        exit; enddo ; ProbeBot(i)=j
      do j=1,m ; if(Zm(j)>=HCone+dCant) exit; enddo;  ProbeTop(i)=j
         b(ProbeBot(i) : ProbeTop(i),i)=0
         u(ProbeBot(i) : ProbeTop(i),i)=1

    elseif (x< RCant) then  ! lever
     nLever=i
     y= HCone
      do j=0,m ; if (zm(j) >=y )        exit; enddo ; ProbeBot(i)=j
      do j=1,m ; if(Zm(j)>=HCone+dCant) exit; enddo;  ProbeTop(i)=j
         b(ProbeBot(i) : ProbeTop(i),i)=0
         u(ProbeBot(i) : ProbeTop(i),i)=1

    elseif (x< RCant+dCant/2 ) then  ! cantelever rounded edge
      nEdge= i
      y= HCone + dCant/2 - sqrt((dCant/2)**2 - (x-RCant)**2)
      do j=0,m ; if (zm(j) >=y ) exit; enddo ; ProbeBot(i)=j
      do j=1,m ; if (Zm(j)>= y+2*  sqrt((dCant/2)**2 - (x-RCant)**2)) exit; enddo;  ProbeTop(i)=j
      !do j=1,m ; if(Zm(j)>=HCone+dCant) exit; enddo;  ProbeTop(i)=j
         b(ProbeBot(i) : ProbeTop(i),i)=0
         u(ProbeBot(i) : ProbeTop(i),i)=1
   endif

enddo
endif
if(z<=d_min+h0/2) then
   open(600,file='ProbeGeometry.dat')
   write(600,*) " # rho, z,   i,  j,  code:  1=sphere, 2=cone, 3=cant, 4= edge"
   Write(600,55)( r(i),zm(ProbeBot(i)),i,ProbeBot(i),1 , i=1        ,nApex )
   Write(600,55)( r(i),zm(ProbeBot(i)),i,ProbeBot(i),2 , i=nApex+1  ,nCone )
   Write(600,55)( r(i),zm(ProbeBot(i)),i,ProbeBot(i),3 , i=nCone+1  ,nLever)
   Write(600,55)( r(i),zm(ProbeBot(i)),i,ProbeBot(i),4 , i=nLever+1 ,nEdge )
   Write(600,55)( r(i),zm(ProbeTop(i)),i,ProbeTop(i),4 , i=nEdge, nLever+1,-1)
   Write(600,55)( r(i),zm(ProbeTop(i)),i,ProbeTop(i),3 , i=nLever,nCone+1 ,-1)
   Write(600,55)( r(i),zm(ProbeTop(i)),i,ProbeTop(i),2 , i=nCone ,nApex+1 ,-1)
   Write(600,55)( r(i),zm(ProbeTop(i)),i,ProbeTop(i),1 , i=nApex      ,1 ,-1)
   55 format(2e15.5 , 3i6)
   close(600)
endif

if(verbose>1) then
If(SphereTest) then
   print'(" *** Test: only sphere, Rtip:",f12.1)', r(nApex)
elseIf(leveronlyTest) then
   print'(" *** Test: only cantilever, Rdisk:",f12.1)', r(nLever)
else
   print'(" Radial extentions cap, cone and  disk:", 3f12.1)', r(nApex),r(nCone),r(nLever)
endif
print*
print*, ' Calculating ....'
print*
print*
endif
end subroutine  SetupProbe ! __ Geometry of Probe   ___________________
!=====================================

subroutine WriteOutputs(k)
integer k
real*8 Er,Ez,Ezbelow,E2,dFz,Fz
50 format (2e13.3,10e20.10)
51 format (2a13,10a20)
print '(a,i3.3)' ," Writing pot & field in fort.?",k
!write (k+1000,*), "#  " , n, m, l , "  #  n , m , l"
!write (k+1000,51), "# rho(nm)  " , "z(nm)  "  ,  "pot(V)", "E2(1/nm)2 " , "E_rho(1/nm)   " , "E_z (1/nm)  " , "grad"
!!do i=1,n-1
!!  do j=1-l,m-1
!do i=0,n
!   do j=-l,m
!      if(i==0) then
!            Er =-(u(j,i+1)-u(j,i))/hn(i)
!      elseif(i==n) then
!            Er = -(u(j,i)-u(j,i-1))/hn(i-1)
!      else
!            Er=-(u(j,i+1)-u(j,i-1))/(hn(i)+hn(i-1))
!      endif
!      if(j==-l) then
!            Ez =-(u(j+1,i)-u(j,i))/hm(j+1)
!      elseif(j==m .or. j==0 ) then
!            Ez = -(u(j,i)-u(j-1,i))/hm(j)
!      else
!            Ez=-(u(j+1,i)-u(j-1,i))/(hm(j)+hm(j+1))
!      endif
!      E2=Ez**2+Er**2
!!     write(k+1000,50)r(i),zm(j),u(j,i),g(j,i), E2 ! ,Er,Ez
!     write(k+1000,50)r(i),zm(j),u(j,i) , E2 , Er, Ez
!  enddo
!  write(k+1000,*)
!enddo
!close(k+1000)
!do j=-l,m
!enddo

! force
write (k+2000,*), "#  " , n, m, l , "  #  n , m , l"
write(k+2000,51) " #  rho ", "  F_z (nN/V2) " , " dF_z(nN/V2) " , "E2 (1/nm)2 " , "E_rho   ","  E_z    " ,  " F_z /pi eps_0 V2 "
Fz=0._dp
do i=0, max( nApex,nCone,nLever,nEdge)-5
  j= ProbeBot(i)
  Er=-(u(j,i+1)-u(j,i))/hn(i)
  Ez=-(u(j,i)-u(j-1,i))/hm(j)
  E2=Er**2+Ez**2
  x=(r(i)+r(i+1))/2._dp
  dFz=E2*x*hn(i)
  Fz=Fz+dFz
 write(k+2000,50)x,Fz*pi_e0,dFz*pi_e0 ,E2 ,Er,Ez , Fz
enddo
close(k+2000)
Force=Fz
! Print '(a,f8.4,e)', '# Z, Force' , Z, Force
! potential and field on the tip axis: (rho=0,z)
write (3000+k,51) "#z(@rho=0) ","    pot.      ", " E_rho  " , " E_z(1/nm)  "
do j=1-l,m-1
  Er=-(u(j,1)-u(j,0))/hn(0)
  Ez=-(u(j+1,0)-u(j-1,0))/(hm(j)+hm(j+1))
write(3000+k,50) zm(j),u(j,0),Er,Ez
enddo
close(3000+k)

! Potential and E-field on the interface: (rho,z=0)
write (4000+k,51) "  # rho(@z=0) ," , "    pot. " , "   E_rho  " , " E_z (top) " , "E_z(belove)"
do i=0,n-1
  if(i==0) then
     Er=-(u(js,1)-u(js,0))/hn(0)
  else
    Er=-(u(js,i+1)-u(js,i-1))/(hn(i-1)+hn(i))
  endif
  Ez=-(u(js+1,i)-u(js,i))/hm(1)
  Ezbelow=-(u(js,i)-u(-1,i))/hm(0)
write(4000+k,50) r(i),u(js,i),Er,Ez,-Ezbelow , -eps_r*Ezbelow ! two last should be the same! checjk the output
enddo
close(4000+k)
end subroutine WriteOutputs

!===============================================
subroutine IntegratedForce
real*8 E2,df
character*200 str
Force=0._dp
write(str,'(a,f6.4)')"Fz.dat",Z/Rtip
open (500, file=str)
write(500,*) "# rho, F_z,dF_z, z(rho), E2 (=>sigma2=e0^2*E2), Er, Ez, Ui,j , Ui+1,j , Ui,j-1"
do i=0,max(nApex,nCone,nLever,nEdge)
  !j=Probebot(i)
  !Er=-(u(j,i+1)-u(j,i))/hn(i)
  !Ez=-(u(j,i)-u(j-1,i))/hm(j)
  !Er=-(u(j,i+2)-u(j,i))/(hn(i)+hn(i+1))
  !Ez=-(u(j,i)-u(j-2,i))/(hm(j)+hm(j-1))
  j=Probebot(i) -1 ! avoid stepwise boundariy
  Er=-(u(j,i+1)-u(j,i))/hn(i)
  Ez=-(u(j,i)-u(j-1,i))/hm(j)
  E2=Er**2+Ez**2
  df=.5_dp*(r(i)+r(i+1)) * hn(i) * E2
  Force=Force+df
  write(500,'(18es15.5)'),.5_dp*(r(i)+r(i+1)) ,Force,dF,zm(Probebot(i)),E2,er,ez,u(j,i),u(j,i+1),u(j-1,i)
  !write(500,'(8es15.5)'),1.*i,1.*j,x,u(j,i),u(j,i+1),u(j-1,i)
enddo
! note that in cylinderical coordinates: dS.n=(2pi r dr)/sin t . sin t =2pi r dr
close(500)
end subroutine IntegratedForce

Subroutine get_time (time)
     integer v(8)
     character*50 time
     call date_and_time(VALUES=v)
     write ( time, "(' Time: ',i2.2,'.',i2.2,'.',i4.4,i6.2,':',i2.2,':',i2.2)") , v(3),v(2),v(1),v(5:7)
end subroutine
end module definitions

!=====================================================
program CapSolCyl   ! Capicatnce Solver with Cylindrical Symmetry
use definitions
implicit none
integer*8 iter
real(8) gnrm0
integer l_js, ij, info ,lmn ,kd,kdA,kdB
integer test
real*8 , allocatable :: Hess (:,:) ! as general band storage
real*8 , allocatable :: gp(:,:)
integer, allocatable :: ipiv(:)
real*8 , allocatable :: HA1(:),HA2(:),HA3(:)
real*8 , allocatable :: HB1(:),HB2(:),HB3(:)
real*8 , allocatable :: Hd_1(:)
real*8 , allocatable :: aa(:,:) , bb(:,:)
real*8 , allocatable :: work(:)
integer, allocatable :: iwork(:)
character*10         :: Method
real*8               :: HessNorm,rcond
real t
real*8 Alpha, anoise , energy1
real*8 arrayC(4),zk
real*8 , allocatable :: arrayE(:),arrayZ(:),arrayF(:)
integer iarray, idstep, ifn
character*25 fn
logical output

 INTEGER*8 pt(64)
 integer  phase
 INTEGER  idum, solver
 INTEGER maxfct, mnum, mtype,  nrhs,  msglvl
 INTEGER iparm(64)
 REAL*8  dparm(64)
 INTEGER  , allocatable :: ia(:)
 INTEGER  , allocatable :: ja(:)
 REAL*8   , allocatable :: a(:)
 REAL*8  waltime1, waltime2, ddum
 character*50  :: str

! print logo
call get_time(str)
write(*,*)
write(*,'(a110)') " N o n u n i f o r m - m e s h   F i n i t e   D i f f e r e n c e                                         "
write(*,'(a110)') "   _____                            _  _                                _____         _                   "
write(*,'(a110)') "  / ____|                          (_)| |                              / ____|       | |                  "
write(*,'(a110)') " | |      __ _  _ __    __ _   ___  _ | |_  __ _  _ __    ___  ___    | (___    ___  | |__   __ ___  _ __ "
write(*,'(a110)') " | |     / _` || '_ \  / _` | / __|| || __|/ _` || '_ \  / __|/ _ \    \___ \  / _ \ | |\ \ / // _ \| '__|"
write(*,'(a110)') " | |____| (_| || |_) || (_| || (__ | || |_| (_| || | | || (__|  __/    ____) || (_) || | \ V /|  __/| |   "
write(*,'(a110)') "  \_____|\__,_|| .__/  \__,_| \___||_| \__|\__,_||_| |_| \___|\___|   |_____/  \___/ |_|  \_/  \___||_|   "
write(*,'(a110)') "               | |                                                                                "
write(*,'(a110)') "               |_|                                    C y l i n d r i c a l   S y m m e t r y   Ver. 0.0  "
write(*,'(a110)') "                                                      (Specialized for AFM Probe over a Multilayer sample)"
write(*,*)
write(*,'(a110)')   trim(str)
write(*,*)
write(*,*)
write(*,*)

str='capsol.in'
open(unit=10,file=str)
verbose=-1
read(10,*,end=99)  n,m,l_js
read(10,*,end=99)  h0,rho_max,z_max
read(10,*,end=99)  d_min,d_max,idstep
read(10,*,end=99)  Rtip,theta,HCone,RCant, dCant
read(10,*,end=99)  eps_r,Hsam
read(10,*,end=99)  Method, test, verbose
!write(*,'(t50," # ")') Alpha, anoise
99 close(10)
Alpha=1_dp
if(verbose==-1) then
   print*,'Error in input file:'//trim(str)
   print*,'Use the templete as in capsol.default'
   open (11,file='capsol.default')
   write(11,'(3i6   ,t50," # Number of grids: n, m+, m-")')  500,500,10 ! n,m,l_js
   write(11,'(f7.3,2EN12.2,t50," # Resolution: h0, Box-size: Rho_max, Z_max    *** ALL LENGTHS IN NANOMETER *** ")') &
                      .5, 1.e6, 1.e6 !h0,rho_max,z_max
   write(11,'(2f10.3,i4,t50," # Tip-sample separation: min, max, istep (stepsize=istep*h0)")') 2., 20.,2 !d_min,d_max,idstep
   write(11,'(2F6.1,3EN12.2,t50," # Probe shape: Rtip,half-angle,HCone,RCantilever, thickness_Cantilever")')  &
                    20., 15., 15.e3, 40.e3, .5e3 !  Rtip,theta,HCone,RCant, dCant
   write(11,'(2EN12.3,t50," # Sample: eps_r, Thickness_sample")') 5., .5 !eps_r,Hsam
   write(11,'(a, i5, i3,t50," # Solving: Method{LAPACK,PARDISO,NOSOLVE}, Test?(0=No,1=Sphere,2=lever-only),Verbosiy>0)")') &
           'LAPACK', 0, 0 !, trim(Method), test, verbose
   close(11)
   stop
endif

if (test==1) spheretest=.true.
if (test==2) leveronlytest=.true.
if(verbose>2) output=.true.

!echo of input
write(*,*) "------------ Echo of input file: "// trim (str) //" ----------"
write(*,'(3i6   ,t50," # Number of grids: n, m+, m-")') n,m,l_js
write(*,'(f7.3,2EN12.2,t50," # Resolution: h0, Box-size: Rho_max, Z_max    *** ALL LENGTHS IN NANOMETER *** ")') &
                  h0,rho_max,z_max
write(*,'(2f10.3,i4,t50," # Tip-sample separation: min, max, istep (stepsize=istep*h0)")') d_min,d_max,idstep
write(*,'(2F6.1,3EN12.2,t50," # Probe shape: Rtip,half-angle,HCone,RCantilever, thickness_Cantilever")')  &
                 Rtip,theta,HCone,RCant, dCant
write(*,'(2EN12.3,t50," # Sample: eps_r, Thickness_sample")') eps_r,Hsam
write(*,'(a, i5, i3,t50," # Solving: Method{LAPACK,PARDISO,NOSOLVE}, Test?(0=No,1=Sphere,2=lever-only),Verbosiy>0)")') &
           , trim(Method), test, verbose
!write(*,*) "=========================== "
write(*,*)
write(*,*)
!write(*,'(t50," # ")') Alpha, anoise

open(300,file='ElecField_mid.dat')
open(301,file='ElecField_gap.dat')

theta=theta*pi/180._dp

!leveronlytest=.true.
Method=trim(Method)
arrayC(1)=4._dp/5 ;arrayC(2)=-1._dp/5 ;arrayC(3)=4._dp/105 ;arrayC(4)=-1._dp/280

iarray=int((d_max-d_min)/(idstep*h0))+1
allocate (arrayE(0:iarray),arrayZ(0:iarray),arrayF(0:iarray))  ; iarray=0
Z=d_min
!write(200,'(a,3i6,9f10.1)') , "#  n,m,l,rho_max,Z_max,Hsam" , n,m,l_js-js,rho_max/1000,Z_max/1000,Hsam/1000
!write(200,'(a7,10a25)') '#  Z  (nm) ', ' energy (nm.nN)  ', 'f=-du/dz (1st order) (nN) ' , ' g=-d2u/dz2 (1st odrder) (nN/nm)'
!write(200,'(a7,10a25)') '#  Z  (nm) ', 'Capacity(nm.nN/V2', 'Cp (nN/V2) ' , ' Cpp (nN/nm.V2)'
open(201, file='Z-U.dat')
write(201,'(a7,10a25)') '#  Z/R', 'U/pie0RV2' ,  'C/pie0R'
!_____________ Z loop
do while(Z<=d_max)
if (method=='NOSOLVE') then
   print*,'No minimization will be done ! '
  goto 1000
endif

! j of the surface; j)apex=0, j_surface=-separation
 js=-nint(Z/h0); l=l_js+(-js)
 lmn=(n+1)*(l+m+1) ; kdA=m+l+1;  kdB=n+1 ; kd=min(kdA,kdB)

 allocate (hn(0:n),r(0:n),hm(-l:m),zm(-l:m))
 call GenerateGrid

 allocate (u(-l:m,0:n),g(-l:m,0:n),b(-l:m,0:n) ) ! uexact , u0
 allocate (ProbeBot(0:n) , ProbeTop(0:n))
 call SetupProbe

 allocate (aa(-l:m,0:n),bb(-l:m,0:n),gp(0:n,-l:m))
 allocate (HA1(lmn),HA2(lmn),HA3(lmn), Hd_1(lmn), HB1(lmn),HB2(lmn),HB3(lmn) , ipiv(lmn))

if (Method ==  'LAPACK') allocate (Hess(0:kd,lmn)) ! Is this because of the banding?
if (Method == 'PARDISO') allocate (ia(lmn+1),ja(3*lmn-kdA-1),a(3*lmn-kdA-1) )

!if(abs(Z-d_min)<h0/2)
! print '(a,3F12.6,e12.5)'," rmax,Zmax,Hsam(mm),eps_r: " ,r(n)/1e6 , zm(m)/1e6 , (zm(js)-zm(-l))/1e6, eps_r

!  constructing constant cooficients  aa ,bb. => they depend only  on geometry and Z
do i=0,n-1
do j=js+1,m
  aa(j,i)=.5_dp*(r(i)+r(i+1)) *hn(i) / hm(j)
  bb(j,i)=.5_dp*(r(i)+r(i+1)) /hn(i) * hm(j)
enddo
do j=-l+1,js
  aa(j,i)=.5_dp*(r(i)+r(i+1)) *hn(i) / hm(j)*eps_r
  bb(j,i)=.5_dp*(r(i)+r(i+1)) /hn(i) * hm(j)*eps_r
enddo
enddo

do i=0,n ;do j=-l,m ;  ij=j+l+1+i*kdA
   if(b(j,i)>0._dp) then
      HA1(ij)= aa(j,i) +bb(j,i); if(i>0) HA1(ij)= HA1(ij)+bb(j,i-1) ; if(j<m) HA1(ij)=HA1(ij)+ aa(j+1,i)
      HA2(ij)=0._dp ; if(j<m) HA2(ij)=-aa(j+1,i)
      HA3(ij)=-bb(j,i)
  else ! on boundry ==> fixed potentional nodes
     HA1(ij)=1._dp  !on diagonal
     if(ij<lmn)    HA2(ij)      = 0._dp ! just belove diagonal
     if(ij>1)      HA2(ij-1)    = 0._dp ! just left of diagonal
     if(ij<lmn-kdA) HA3(ij)     = 0._dp ! far belove diagonal
     if(ij>kdA)     HA3(ij-kdA) = 0._dp ! for left of diagonal
  endif
enddo; enddo

do j=-l,m ;do i=0,n ; ij=i+1+(j+l)*kdB
   if(b(j,i)>0._dp) then
      HB1(ij)= aa(j,i)  +bb(j,i) ; if(i>0) HB1(ij)=HB1(ij)+ bb(j,i-1); if(j<m) HB1(ij)=HB1(ij)+ aa(j+1,i)
      HB3(ij)=0._dp; if(j<m)  HB3(ij)=-aa(j+1,i)
      HB2(ij)=-bb(j,i)
HB2(ij)=-bb(j,i)
  else ! on boundry ==> fixed potentional nodes
     HB1(ij)=1._dp  !on diagonal
    if(ij<lmn)      HB2(ij)    = 0._dp ! just belove diagonal
    if(ij>1)        HB2(ij-1)  = 0._dp ! just left of diagonal
     if(ij<lmn-kdB) HB3(ij)    = 0._dp ! far belove diagonal
     if(ij>kdB)     HB3(ij-kdB)= 0._dp ! for left of diagonal
  endif
enddo; enddo
! ____ Hessian ___________
if (Method=='LAPACK') then
   if(kd==kdB) then
     Hess=0._dp
     Hess(0,:) = HB1  ! + 1.d-8
     Hess(1,:) = HB2
     Hess(kd,:)= HB3
   else
     Hess=0._dp
     Hess(0,:) = HA1  ! + 1.d-8
     Hess(1,:) = HA2
     Hess(kd,:)= HA3
   endif
!  HessNorm=0._dp
!   do i=1,lmn
!        x=abs(Hess(0,i))+abs(Hess(1,i))+abs(Hess(kd,i))
!        if(i>1) x=x+abs(Hess(1,i-1))
!        if(i>kd) x=x+abs(Hess(kd,i-kd))
!        if(x>HessNorm) HessNorm=x
!  enddo
!     print *, 'Matrix factorization  by LAPACK ...'
     call dpbtrf( 'L', lmn,kd,Hess,kd+1,info)
     if(info /= 0) then
        print*, info , 'Failure in factorization Hessain matrix ';  stop
     endif
!print*, ' Estimating condition number ...'
!   allocate (work(3*lmn) , iwork(lmn))  ! as general band storage
!call dpbcon('L',lmn,kd,Hess,kd+1,HessNorm,rcond,work,iwork,info)
!   if(info /= 0) then
!      print*, info , 'Failure in estimating condition number'; stop
!   else
!      print '(a,2e10.1)',' Condition number of Full Hessian= ' , 1._dp/rcond , HessNorm
!   endif
!deallocate (  work , iwork)  ! as general band storage

! _ Hessian ___________

elseif  (Method == 'PARDISO') then
       ij=0
       do k=1,lmn
         ij=ij+1;
         ia(k)=ij
         ja(ij)=k
         a(ij)=HA1(k)

       if(k<lmn) then
         ij=ij+1
         ja(ij)=k+1
         a(ij)=HA2(k)
       endif

       if(k<= lmn -kdA) then
       ij=ij+1
       ja(ij)=k+kdA
        a(ij)=HA3(k)
       endif
     enddo
     ia(lmn+1)=ij+1
     mtype =2  ! 2 for symmetric positive definite mantrix  , -2 for symmetrtic indefinite
     solver=  0  ! use sparse direct method
     maxfct=1
     mnum=1
     nrhs=1
!!   call pardisoinit(pt, mtype, solver, iparm, dparm, info)
   if(info /= 0) then
      print*, info , 'Failure in Inintializibg by PARDISO' , info  ;  stop
   endif
      iparm(6) = 1  !  0=> output on x  , 1 => output on b
      iparm(3) = 1   !  .. Numbers of Processors ( value of OMP_NUM_THREADS )
      iparm(8)  = 1   ! max numbers of iterative refinement steps
      msglvl    = 0      ! without statistical information
!      print *, 'Matrix factorization ... by PARDISO'
      phase    = 12  ! Analysis, Numerical Factorization, Solve, Iterative Refinent
!!  call pardiso (pt, maxfct, mnum, mtype, phase, lmn, a, ia, ja,  idum, nrhs, iparm, msglvl, g,gp, info, dparm)
   if(info /= 0) then
      print*, info , 'Failure in factorization a matrix by PARDISO' , info  ;  stop
   endif

! Since now, a(1:3lmn-kd-1) in factorized form

else
   print*,'Not recognizing Method, Exit...' ; stop
endif

!______________________________ minimization

!write(*,'(a10,a30,2a15,a12,a)') "Itration " ,"Energy (nm.nN/V2) "," Gnrm   " , " Gnrm/Gnrm0  ","Del Energy ", " time(min)"
iter=-1
energy1=1.d100
do
  iter=iter+1

  !__________ calculate energy and its gradient ________________
energy=0._dp
do i=0,n-1; do j=-l+1,m
    energy=energy+aa(j,i)*(u(j,i)-u(j-1,i))**2 + bb(j,i)*(u(j,i+1)-u(j,i))**2
enddo; enddo

gnrm=0._dp
i=0; do j=-l+1,m-1 ! on j=m pot is fixed
    g(j,i)=b(j,i)*(                     - u(j-1,i)*aa(j,i) + &
           u(j,i)*(            aa(j,i) + aa(j+1,i) + bb(j,i)) -u(j+1,i)*aa(j+1,i)-u(j,i+1)*bb(j,i))
    gnrm=gnrm +g(j,i)**2
 enddo
do i=1,n-1; do j=-l+1,m-1  ! j=m ==> boundry
    g(j,i)=b(j,i)* ( -u(j,i-1)*bb(j,i-1) - u(j-1,i)*aa(j,i) + &
           u(j,i)*(bb(j,i-1) + aa(j,i) + aa(j+1,i) + bb(j,i)) -u(j+1,i)*aa(j+1,i)-u(j,i+1)*bb(j,i))
    gnrm=gnrm +g(j,i)**2
enddo; enddo
gnrm=sqrt(gnrm)

IF (Method=='LAPACK') THEN
!_____________________________________________________________________________________
  if (iter<2) gnrm0=gnrm

   if(kd==kdB) then ! use B
       do i=0,n; do j=-l,m ;  gp(i,j)=g(j,i); enddo;enddo
       call dpbtrs('L',lmn,kd,1,Hess,kd+1,gp, lmn,info)
       do i=0,n; do j=-l,m ;  g(j,i)=gp(i,j); enddo;enddo
   else ! use A
       call dpbtrs('L',lmn,kd,1,Hess,kd+1,g, lmn,info)
   endif
    if(info /=0) then
         print* , info , "Fail in dgbtrs" ; stop
    endif
    do i=0, n-1
            do j=-l,m
                  u(j,i)=u(j,i)-Alpha*g(j,i);   ! for Whole Hessian H
           enddo
    enddo
!_____________________________________________________________________________________
ELSEIF (Method=='PARDISO') THEN
  if (iter<2) gnrm0=gnrm
      phase    = 33  ! Solve, Iterative Refinent
!     CALL pardiso (pt, maxfct, mnum, mtype, phase, lmn, a, ia, ja,  idum, nrhs, iparm, msglvl, g,gp ,  info, dparm)

   if(info  /= 0) then
      print*, info , 'Failure in Solving a  by PARDISO' , info  ;  stop
   endif
         do i=0, n-1
            do j=-l,m
                   u(j,i)=u(j,i)-Alpha*g(j,i);
            enddo
         enddo

!_____________________________________________________________________________________
ELSEIF (Method=='CROSS') THEN ! use tridiag. H
  if (iter<100) gnrm0=gnrm
  if(mod(iter,2)/=0) then  ! A for Crossing
  !if(mod(iter,2)==0) then  ! A for Crossing
        call dpttrs (lmn, 1, HA1, HA2, g, lmn, info)  ! Now g is not gradient, but is P=H-1 g
  else                     ! B for Crossing
      do i=0,n; do j=-l,m  ;   gp(i,j)=g(j,i);   enddo;enddo
          call dpttrs (lmn, 1, HB1, HB2, gp, lmn, info)  ! Now g is not gradient, but is P=H-1 g
      do i=0,n; do j=-l,m ;  g(j,i)=gp(i,j) ;enddo;enddo
   endif

   if(info /=0) then
         print* , info , 'Failure in dpttrs'  ; stop
   endif

    do i=0, n-1
            do j=-l,m
                   u(j,i)=u(j,i)-Alpha*g(j,i);   ! for tridiagonal H
           enddo
    enddo
!_____________________________________________________________________________________

ENDIF   ! METHOD

if ( mod(iter,1)==0) then
!      call cpu_time(t) ;  print '(i10,e,e10.3,f10.2)', Iter,energy*pi_e0,gnrm !, t/60
endif
  if (gnrm <1.d-5*gnrm0) exit ! Converge
  if (energy1-energy<anoise) exit

  energy1=energy
! print*,method, iter, gnrm,energy
enddo  ! next iteratin
call cpu_time(t)

! _________End of minimization _____________________________________________

call IntegratedForce
!write(* ,'(a,f5.2,3i5,2e,f10.2 , i3 )')    ' FINAL Z,n,m,l,Energy & Force, cpu time: , Iter',Z,n,m,l,energy*pi_e0,Force*pi_e0 , t/60 , Iter
write(* ,'(a,f9.4,e15.7 )')    ' ===S/R,C/pi.e0.R:',Z/Rtip,2_dp*energy/Rtip
write(* ,'(60x,a,f5.2,e15.7,f10.2 )')    ' +++Separation,Capacitance, cpu time: ',Z,2_dp*energy*pi_e0 ,  t
!write(200 ,'(f10.5,2es )')     Z,energy*2*pi_e0  ! C=2U/V2 and V=1
write(201 ,'(f10.5,2es15.7 )')     Z/Rtip,energy/Rtip,  2._dp*energy/Rtip

j=js/2; Ez=-(u(j+1,0)-u(j-1,0))/(hm(j)+hm(j+1))
write(300,'(f10.4,E13.3, f6.2,E16.6,f8.2, E16.6, a )')   &
       z/Rtip,Ez*Rtip, z,Ez,z*10._dp ,Ez/27.211396132_dp*0.052917725_dp   , ' # s, E_mid: R,1/R;   nm, 1/nm; angs, Ha/Bohr'

write(301,*)
write(301,*) "# along tip axis: rho=0, s=",z
!do j=js-3,3
do j=js-2,2
      Ez=-(u(j+1,0)-u(j-1,0))/(hm(j)+hm(j+1))
      write(301,'(f6.2,E16.6, f10.4,E13.3,a)') (zm(j)-zm(js)) ,Ez ,(zm(j)-zm(js))/Rtip,Ez*Rtip &
          , ' # z (nm) , Ez(1/nm)      , z/R, Ez/(V/R) ' !
enddo

if(output)  call WriteOutputs( nint(Z*100))
!_____________ Z loop
!Z=Z+idstep*h0
! ????????? if(Z>= d_max *.9999) call WriteOutputs (99)
if(Method=='PARDISO') then
!  phase  = -1; CALL pardiso (pt, maxfct, mnum, mtype, phase, lmn, a, ia, ja,  idum, nrhs, iparm, msglvl, g,gp ,  info, dparm)
endif

 deallocate (hn,r,hm,zm)
 deallocate (u,g,b ) ! uexact , u0
 deallocate (aa,bb,gp)
 deallocate (ProbeBot,ProbeTop )
 deallocate (HA1,HA2,HA3, Hd_1, HB1,HB2,HB3, ipiv)

if (Method ==  'LAPACK') deallocate (Hess)
if (Method == 'PARDISO') deallocate (ia,ja,a)

1000 continue ! end of minimization

!if (spheretest)  call exactsphere (z,rtip,eps_r)
!if (spheretest) then
!        call ImageCharges(z)
      ! write(*,'(f7.3,e23.13,e13.3,e12.3,f9.3,i12,2e9.2,a)')z,cap,cap/Cexact-1,fexact,h0,(n+1)*(m+l+1),z_max,rho_max, '    # s,Cnum,err,Fexact,h0, N,z_max,rho_max'
!endif

Z=Z+idstep*h0
enddo  ! next Z

call get_time(str)
write(*,'(a110)')
write(*,'(a110)')   " G O O D   B Y E !     " //  trim(str)
write(*,'(a110)')
end


program tarefac
    implicit real(8) (a-h,o-z)

    dt = 0.001d0
    tmax = 240d0

    g = 9.8d0
    a_l = 9.8d0
    gama = 0.5d0
    Omega = 2d0/3d0

    write(*,*) 'Entre com o valor de F0:'
    read(*,*) F0

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

    theta_i = 0.2d0
    omega_i = 0d0
    i = 0
    n = 0
    a_lyapunov = 0d0

    do while ( i*dt.le.tmax )

        dw_i = dw(g, a_l, theta_i, gama, omega_i, F0, Omega, dt*i)
        call oscilacao(theta_i, omega_i, dw_i, dt)

        write(10, *) theta_i, omega_i

        i = i+1
    end do

    close(10)

contains
    function dw(g, a_l, theta, gama, dTheta, F0, Omega, t)
        implicit real(8) (a-h,o-z)
        dw = -(g/a_l)*sin(theta) -gama*dTheta +F0*sin(Omega*t)
        return
    end function

    subroutine oscilacao(theta_i, omega_i, dw_i, dt)
        implicit real(8) (a-h,o-z)
        parameter (pi = 4d0*atan(1d0))
        omega_i = omega_i +dw_i*dt
        theta_i = theta_i +omega_i*dt

        do while (abs(theta_i).ge.pi)
            sinal = theta_i/abs(theta_i)
            theta_i = theta_i -sinal*2*pi
        end do
        return
    end subroutine

end program tarefac


\ fib.f         - x4 fibonacci benchmark words
\ ------------------------------------------------------------------------

 .( loading fib.f ) cr

\ ------------------------------------------------------------------------

9000000 var itters          \ 9 million

0 var counter

\ ------------------------------------------------------------------------
\ removed from the kernel because i discourage its use and this example
\ is the only place i use it

: recurse
  last name> , ;            ; foot in self shoot

\ ------------------------------------------------------------------------
\ the recursive method - this we call once not 9 milion times :)

\ this word recurses on itself one hundred and thirteen million times
\ to calculate the 40th fib (bleh)

: fib1          ( n1 --- )
  dup 1 >
  if
    dup  1- recurse
    swap 2- recurse
    +
  then ;

\ ------------------------------------------------------------------------
\ this code is more proof that anything you can do with recursion
\   can be done better without.

1 var f1
0 var f2

: fib2
  off> f2
  1 !> f1
  1
  ?do
    f2 f1 +
    f1 !> f2
    !> f1
  loop f1 ;

\ ------------------------------------------------------------------------
\ this is my version of the above itterative method

: fib3
  0 1 rot 1
  ?do
    tuck +
  loop nip ;

\ ------------------------------------------------------------------------

: (fib4) tuck + ;
: fib4 1 1 rot 1- rep (fib4) drop ;

\ ------------------------------------------------------------------------

: fib-bench
  cr ." fib 1 " timer-reset             40 fib1 drop      .elapsed
  cr ." fib 2 " timer-reset itters 0 do 40 fib2 drop loop .elapsed
  cr ." fib 3 " timer-reset itters 0 do 40 fib3 drop loop .elapsed
  cr ." fib 4 " timer-reset itters 0 do 40 fib4 drop loop .elapsed ;

\ fib1 rubs in  4:06 on my k6-3/550
\ fib2 runs in 17:56
\ fib3 runs in  0:32

\ ========================================================================


C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE DHLSRGB(H,L,S,R,G,B)
C
C_BEGIN PROLOGUE DHLSRGB
C
C_PURPOSE
C    This subroutine converts a color specification given in
C    the Hue, Lightness, and Saturation color space to
C    Red, Green, and Blue intensity values in the RGB color
C    space.
C
C_DESCRIPTION
C    This subroutine converts color values given in the
C    Hue, Lightness, Saturation (HLS) color space to color values
C    in the Red, Green, and Blue (RGB) color space.
C    The input value H is a floating point number in the
C    range [0.,360.); a value of H=0. in the input space
C    will result in a full blue (red and green values of 0.)
C    in the RGB space.  The input value L is in the range
C    [0.,100.]; lightness is used to signify the amount of light--
C    L=0. will result in R=G=B=0. and L=1. will result in
C    R=G=B=1. regardless of H and S.  The input value S is
C    in the range [0.,100.];  saturation is a measure of the
C    mixture of white light with a pure fully-saturated hue--
C    S=0. will result in R=G=B=L.  The output values
C    R, G, and B are red, green, and blue intensities
C    in the range 0. to 1. .
C
C_ARGUMENTS
C
C H       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,360.) which represents the hue of the input color
C         in HLS color space.  H=0. corresponds to blue.
C
C L       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,100.] which represents the lightness value of the
C         input color in HLS color space.  Lightness is a measure
C         of the quantity of light--a lightness of 0. is black,
C         and a lightness of 100. gives white.  The pure hues occur
C         at lightness value 50.
C
C S       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,100.] which represents the saturation value of the
C         input color in HLS color space.  Saturation is a measure
C         of how much white light is mixed with the color. Colors
C         having a satuartion value of 0. represent greys
C         with a grey intensity value equal to the lightness L.
C         Colors with a saturation value of 100. are
C         fully saturated colors.  The hue is undefined
C         when S=0.  The fully saturated pure hues occur when S=100.
C         and L=50.
C
C R       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the red intensity component
C         of the output color in RGB color space.
C
C G       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the green intensity component
C         of the output color in RGB color space.
C
C B       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the blue intensity component
C         of the output color in RGB color space.
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    DSIGPLC
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    880511 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded at NCAR by Roy Barnes
C    using the algorithm presented in Foley and van Dam (see
C    REFERENCES below); it was prepared for the NCAR Graphics
C    package by Fred Clare.
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C    Smith, A.R.,"Color Gamut Transformation Pairs",SIGGRAPH '78
C    Proceedings, published as Computer Graphics, 12(3),August 1978,
C    pp.12-19.
C
C_LONG DESCRIPTION
C    The idea of the algorithm can be understood if one were to
C    plot the red output values vs. hue for S=100. and L=50.  The red
C    values so plotted form a piecewise linear curve.  The blue
C    and green values plotted in the same way form the same
C    piecewise linear curve except shifted.  Decreasing the
C    saturation pushes the curves toward the lightness value,
C    and varying the lightness introduces an amplitude scale
C    factor and vertical offset.
C
C_EXAMPLES
C    Example 1 --  Pure hue to red.
C          SUBROUTINE HLS2
C          DOUBLE PRECISION  R,G,B,EPS
C          PARAMETER (EPS=0.00001)
C          CALL DHLSRGB(120.,50.,100.,R,G,B)
C          IF ( (ABS(R-1.) .GT. EPS) .OR. (ABS(G) .GT. EPS) .OR.
C         *     (ABS(B) .GT. EPS) ) THEN
C            IUN = I1MACH(4)
C            WRITE(IUN,10)
C          ENDIF
C          RETURN
C       10 FORMAT(' HLS2 returned incorrect values')
C          END
C
C_END PROLOGUE DHLSRGB
C
      DOUBLE PRECISION H,HH,L,S,R,G,B,LL,SS,M1,M2,DSIGPLC
C
C  Check on the input values.
C
C_FIRST EXECUTABLE STATEMENT DHLSRGB
      HH = MOD(H,360.D0)
      IF (HH.LT.0.D0) HH = HH + 360.D0
      IF (L.LT.0.D0 .OR. L.GT.100.D0)
     +    CALL SETER(' DHLSRGB - L out of range',1,1)
      IF (S.LT.0.D0 .OR. S.GT.100.D0)
     +    CALL SETER(' DHLSRGB - S out of range',1,1)
C
C  Normalize lightness and saturation values.
C
      LL = L/100.D0
      SS = S/100.D0
      IF (SS.EQ.0.0D0) THEN
C
C  Achromatic case; RGB value is a grey equal to the lightness.
C
          R = LL
          G = LL
          B = LL
      ELSE
C
C  Calculate the max and min of the generic piecewise linear
C  color component function.
C
          IF (LL.LE.0.5D0) THEN
              M2 = LL* (1.0D0+SS)
          ELSE
              M2 = LL + SS - (LL*SS)
          END IF
          M1 = 2.0D0*LL - M2
C
C  Compute RGB values.
C
          R = DSIGPLC(M1,M2,HH+0.D0)
          G = DSIGPLC(M1,M2,HH-120.D0)
          B = DSIGPLC(M1,M2,HH+120.D0)
      END IF
      RETURN
      END
      SUBROUTINE DHSVRGB(H,S,V,R,G,B)
C
C_BEGIN PROLOGUE HSVRGB
C
C_PURPOSE
C    This subroutine converts a color specification given in
C    the Hue, Saturation, and Value color space to
C    Red, Green, and Blue intensity values in the RGB color
C    space.
C
C_DESCRIPTION
C    This subroutine converts color values given in the
C    Hue, Saturation, and Value (HSV) color space to color values
C    in the Red, Green, and Blue (RGB) color space.
C    The input value H is a floating point number in the
C    range [0.,360.); a value of H=0. in the input space
C    will result in a full red (green and blue values of 0.)
C    in the RGB space.  The input value V is in the range
C    [0.,1.];  the input value S is
C    in the range [0.,1.];  saturation is a measure of the
C    mixture of white light with a pure fully-saturated hue--
C    S=0. will result in R=G=B=V.  The output values
C    R, G, and B are red, green, and blue intensities
C    in the range [0.,1.] .
C
C_ARGUMENTS
C
C H       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,360.) which represents the hue of the input color
C         in HSV color space.
C
C S       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the saturation value of the
C         input color in HSV color space.  Saturation is a measure
C         of how much white light is mixed with the color. Saturation
C         values of 0. represent greys (with a grey value equal to
C         the value V).  Saturation values of 1. are fully
C         saturated colors.  The hue is undefined when S=0.  The
C         fully saturated pure hues occur when S=1. and V=1.
C
C V       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the value of the
C         input color in HSV color space.
C
C R       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the red intensity component
C         of the output color in RGB color space.
C
C G       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the green intensity component
C         of the output color in RGB color space.
C
C B       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the blue intensity component
C         of the output color in RGB color space.
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    DSIGPLC
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    880511 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded and prepared for the
C    NCAR Graphics package by Fred Clare based on algorithms
C    in Foley and van Dam (see REFERENCES below).
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C    Smith, A.R.,"Color Gamut Transformation Pairs",SIGGRAPH '78
C    Proceedings, published as Computer Graphics, 12(3),August 1978,
C    pp.12-19.
C
C_LONG DESCRIPTION
C    The idea of the algorithm can be understood if one were to
C    plot the red output values vs. hue with S=1. and V=1.  The red
C    values so plotted form a piecewise linear curve.  The blue
C    and green values plotted in the same way form the same
C    piecewise linear curve except shifted.  Decreasing the
C    saturation pushes the curves toward the input value V,,
C    and varying the value, V, introduces an amplitude scale
C    factor.  Drawing plots of the red, green, and blue output
C    values vs. hue for selected values of S, and V should
C    provide an intuitive feel for the algorithm.
C
C_EXAMPLES
C    Example 1 --  Pure hue in HSV to green in RGB.
C          SUBROUTINE HSV2
C          DOUBLE PRECISION    R,G,B,EPS
C          PARAMETER (EPS=0.00001)
C          CALL HSVRGB(120.,1.,1.,R,G,B)
C          IF ( (ABS(R-0.) .GT. EPS) .OR. (ABS(G-1.) .GT. EPS) .OR.
C         *     (ABS(B-0.) .GT. EPS) ) THEN
C            IUN = I1MACH(4)
C            WRITE(IUN,10)
C          ENDIF
C          RETURN
C       10 FORMAT(' HSV2 returned incorrect values')
C          END
C
C_END PROLOGUE HSVRGB
C
      DOUBLE PRECISION H,HH,S,V,R,G,B,SM1,DSIGPLC
C
C  Check on the input values.
C
C_FIRST EXECUTABLE STATEMENT HSVRGB
      HH = MOD(H,360.D0)
      IF (HH.LT.0.D0) HH = HH + 360.D0
      IF (S.LT.0.D0 .OR. S.GT.1.D0) CALL SETER
     +    (' HSVRGB - S out of range',1,1)
      IF (V.LT.0.D0 .OR. V.GT.1.D0) CALL SETER
     +    (' HSVRGB - V out of range',1,1)
C
      IF (S.EQ.0.0D0) THEN
C
C  Achromatic case; RGB value is a grey equal to V;
C  H is not defined.
C
          R = V
          G = V
          B = V
      ELSE
C
C  Calculate RGB values.
C
          SM1 = (1.D0-S)*V
          R = DSIGPLC(SM1,V,HH+120.D0)
          G = DSIGPLC(SM1,V,HH+0.D0)
          B = DSIGPLC(SM1,V,HH+240.D0)
      END IF
      RETURN
      END
C
C     $Id: dcolconv.f,v 1.2 2008-07-27 03:40:25 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
      SUBROUTINE DRGBHLS(R,G,B,H,L,S)
C
C_BEGIN PROLOGUE RGBHLS
C
C_PURPOSE
C    This subroutine converts a color specification given as
C    Red, Green, and Blue intensity values to a color specification
C    given as Hue, Lightness, and Saturation values.
C
C_DESCRIPTION
C    This subroutine converts color values given in the
C    Red, Green, Blue (RGB) color space to color values
C    in the Hue, Lightness, and Saturation (HLS) color space.
C    The input Red, Green, and Blue values are intensities
C    in the range [0.,1.]; the output value H is returned
C    as a floating point number in the range [0.,360.);
C    full blue in the input space (red and green values of 0.)
C    corresponds to a hue of 0. in the
C    output space; the output value L is returned as a
C    floating point number in the range [0.,100.];
C    the output value S is returned as a floating
C    point number in the range [0.,100.] .
C
C_ARGUMENTS
C
C R       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the red intensity component
C         of the input point in RGB color space.
C
C G       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the green intensity component
C         of the input point in RGB color space.
C
C B       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the blue intensity component
C         of the input point in RGB color space.
C
C H       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,360.) which represents the hue of the input point
C         in HLS color space.  A value of (0.,0.,B) in the input
C         space will result in a hue of 0. in the output space.
C
C L       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,100.] which represents the lightness value of the
C         input point in HLS color space.  Lightness is a measure
C         of the quantity of light--a lightness of 0. is black,
C         and a lightness of 100. gives white.  The pure hues occur
C         at lightness value 50.  The lightness should be thought
C         of as a percentage.
C
C S       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,100.] which represents the saturation value of the
C         input point in HLS color space.  Saturation is a measure
C         of how much white light is mixed with the color.  Saturation
C         values of 0. represent greys (with a grey value equal to
C         the lightness value L).  Saturation values of 100. are fully
C         saturated colors.  The hue is undefined when S=0.  The
C         fully saturated pure hues occur when S=100. and L=50.
C         The saturation value should be thought of as a percentage.
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    (NONE)
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    880511 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded at NCAR by Roy Barnes
C    based on the algorithm presented in Foley and van Dam (see
C    REFERENCES below); it was prepared for the NCAR Graphics
C    package by Fred Clare.
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C    Smith, A.R.,"Color Gamut Transformation Pairs",SIGGRAPH '78
C    Proceedings, published as Computer Graphics, 12(3),August 1978,
C    pp.12-19.
C
C_LONG DESCRIPTION
C    The hues returned can be made to put 0 degrees at red instead
C    of blue by changing the offsets to the computation of H in the
C    code.  Hue 0. representing blue, and S and L values ranging
C    from 0. to 100. instead of 0. to 1. were chosen for compatability
C    with the Tektronix color model, and compatibility with the
C    NCAR FORTRAN CGM translator GRAPHCAPs.
C
C_EXAMPLES
C    Example 1 --  Pure red at full intensity to HLS
C          SUBROUTINE HLS1
C          DOUBLE PRECISION    H,L,S,EPS
C          PARAMETER (EPS=0.00001)
C          CALL RGBHLS(1.,0.,0.,H,L,S)
C          IF ( (ABS(H-120.) .GT. EPS) .OR. (ABS(L-50.) .GT. EPS) .OR.
C         *     (ABS(S-100.) .GT. EPS) ) THEN
C            IUN = I1MACH(4)
C            WRITE(IUN,10)
C          ENDIF
C          RETURN
C       10 FORMAT(' HLS1 returned incorrect values')
C          END
C
C_END PROLOGUE RGBHLS
C
      DOUBLE PRECISION R,G,B,H,L,S,MXINTS,MNINTS,MAXMIN,HSAV,BC,GC,RC,
     +                 RMM
      SAVE HSAV
      DATA HSAV/0.D0/
C
C  Check on input arguments.
C
C_FIRST EXECUTABLE STATEMENT RGBHLS
      IF (R.LT.0.D0 .OR. R.GT.1.D0) CALL SETER
     +    (' RGBHLS - R out of range',1,1)
      IF (G.LT.0.D0 .OR. G.GT.1.D0) CALL SETER
     +    (' RGBHLS - G out of range',1,1)
      IF (B.LT.0.D0 .OR. B.GT.1.D0) CALL SETER
     +    (' RGBHLS - B out of range',1,1)
      MXINTS = MAX(R,G,B)
      MNINTS = MIN(R,G,B)
C
C  Compute lightness
C
      L = (MXINTS+MNINTS)*0.5D0
      IF (MXINTS.EQ.MNINTS) THEN
C
C  Achromatic case.  If the saturation is 0., then leave H
C  as it was in the previous call as per the suggestion of
C  A.V. Smith (see REFERENCES).
C
          S = 0.0D0
          H = HSAV
      ELSE
C
C  Chromatic case.
C
          MAXMIN = MXINTS - MNINTS
          IF (L.LE.0.5D0) THEN
              S = MAXMIN/ (MXINTS+MNINTS)
          ELSE
              S = MAXMIN/ (2.0D0-MXINTS-MNINTS)
          END IF
          RMM = 1.D0/MAXMIN
          RC = (MXINTS-R)*RMM
          GC = (MXINTS-G)*RMM
          BC = (MXINTS-B)*RMM
          IF (R.EQ.MXINTS) THEN
              H = 2.D0 + BC - GC
          ELSE IF (G.EQ.MXINTS) THEN
              H = 4.D0 + RC - BC
          ELSE IF (B.EQ.MXINTS) THEN
              H = 0.D0 + GC - RC
          END IF
C
C  Convert H to degrees.
C
          H = H*60.D0
          IF (H.LT.0.D0) H = H + 360.D0
          HSAV = H
      END IF
C
C  Scale lightness and saturation values.
C
      L = L*100.D0
      S = S*100.D0
      L = MIN(100.D0,MAX(0.D0,L))
      S = MIN(100.D0,MAX(0.D0,S))
      RETURN
      END
C
C     $Id: dcolconv.f,v 1.2 2008-07-27 03:40:25 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 DRGBHSV(R,G,B,H,S,V)
C
C_BEGIN PROLOGUE RGBHSV
C
C_PURPOSE
C    This subroutine converts a color specification given as
C    Red, Green, and Blue intensity values to a color specification
C    in the Hue, Saturation, Value color space.
C
C_DESCRIPTION
C    This subroutine converts color values given in the
C    Red, Green, Blue (RGB) color space to color values
C    in the Hue, Saturation, and Value (HSV) color space.
C    The input Red, Green, and Blue values are intensities
C    in the range [0.,1.]; the output value H is returned
C    as a floating point number in the range [0.,360.) .
C    Full red (green and blue values of 0.) in the
C    input space corresponds to a hue of 0 in the
C    output space; the output value V is returned as a
C    floating point number in the range [0.,1.];
C    the output value S is returned as a floating
C    point number in the range [0.,1.] .
C
C_ARGUMENTS
C
C R       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the red intensity component
C         of the input point in RGB color space.
C
C G       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the green intensity component
C         of the input point in RGB color space.
C
C B       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the blue intensity component
C         of the input point in RGB color space.
C
C H       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,360.) which represents the hue of the input point
C         in HSV color space.  A value of (R,0.,0.) in the input
C         space will result in a hue of 0. in the output space.
C
C S       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the saturation value of the
C         input point in HSV color space.  Saturation is a measure
C         of how much white light is mixed with the color. Saturation
C         values of 0. represent greys (with a grey value equal to
C         V).  Saturation values of 1. are fully saturated colors.
C         The hue is technically undefined when S=0; the code leaves
C         H at its previous value when S=0. (0. initially).  The
C         fully saturated pure hues occur when S=1. and V=1.
C
C V       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the value in HSV space.
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    (NONE)
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    880511 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded and prepared for the
C    NCAR Graphics package by Fred Clare based on algorithms
C    in Foley and van Dam (see REFERENCES below).
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C    Smith, A.R.,"Color Gamut Transformation Pairs",SIGGRAPH '78
C    Proceedings, published as Computer Graphics, 12(3),August 1978,
C    pp.12-19.
C
C_LONG DESCRIPTION
C    The hues returned can be made to put 0 degrees at blue instead
C    of red by changing the offsets to the computation of H in the
C    code.
C
C_EXAMPLES
C    Example 1 --  Blue to HSV.
C          SUBROUTINE THSV1
C          DOUBLE PRECISION    H,S,V,EPS
C          PARAMETER (EPS=0.00001)
C          CALL RGBHSV(0.,0.,1.,H,S,V)
C          IF ( (ABS(H-240.) .GT. EPS) .OR. (ABS(S-1.) .GT. EPS) .OR.
C         *     (ABS(V-1.) .GT. EPS) ) THEN
C            IUN = I1MACH(4)
C            WRITE(IUN,10)
C          ENDIF
C          RETURN
C       10 FORMAT(' THSV1 returned incorrect values')
C          END
C
C_END PROLOGUE RGBHSV
C
      DOUBLE PRECISION R,G,B,H,S,V,HSAV,RMM,MXINTS,MNINTS,MAXMIN,BC,GC,
     +                 RC
      SAVE HSAV
      DATA HSAV/0.D0/
C
C  Check on input arguments.
C
C_FIRST EXECUTABLE STATEMENT RGBHSV
      IF (R.LT.0.D0 .OR. R.GT.1.D0) CALL SETER
     +    (' RGBHSV - R out of range',1,1)
      IF (G.LT.0.D0 .OR. G.GT.1.D0) CALL SETER
     +    (' RGBHSV - G out of range',1,1)
      IF (B.LT.0.D0 .OR. B.GT.1.D0) CALL SETER
     +    (' RGBHSV - B out of range',1,1)
C
      MXINTS = MAX(R,G,B)
      MNINTS = MIN(R,G,B)
      MAXMIN = MXINTS - MNINTS
C
C  Compute value.
C
      V = MXINTS
C
C  Compute saturation.
C
      IF (MXINTS.EQ.0.D0) THEN
          S = 0.D0
      ELSE
          S = MAXMIN/MXINTS
      END IF
C
C  Compute hue.  If the saturation is 0., then do not define the hue--
C  leave it as it was in the previous call as per the suggestion of
C  A.V. Smith (see REFERENCES).
C
      IF (S.GT.0.D0) THEN
          RMM = 1.D0/MAXMIN
          RC = (MXINTS-R)*RMM
          GC = (MXINTS-G)*RMM
          BC = (MXINTS-B)*RMM
          IF (R.EQ.MXINTS) THEN
              H = 0.D0 + BC - GC
          ELSE IF (G.EQ.MXINTS) THEN
              H = 2.D0 + RC - BC
          ELSE IF (B.EQ.MXINTS) THEN
              H = 4.D0 + GC - RC
          END IF
C
C  Convert H to degrees.
C
          H = H*60.D0
          IF (H.LT.0.D0) H = H + 360.D0
          HSAV = H
      ELSE
          H = HSAV
      END IF
C
C  Guarantee saturation and value are in range.
C
      S = MIN(1.D0,MAX(0.D0,S))
      V = MIN(1.D0,MAX(0.D0,V))
      RETURN
      END
C
      SUBROUTINE DRGBYIQ(R,G,B,Y,I,Q)
C
C_BEGIN PROLOGUE RGBYIQ
C
C_PURPOSE
C    This subroutine converts a color specification given as
C    Red, Green, and Blue intensity values to a color specification
C    in the YIQ color space.
C
C_DESCRIPTION
C    This subroutine converts color values given in the
C    Red, Green, Blue (RGB) color space to color values
C    in the YIQ color space.  The input Red, Green,
C    and Blue values are intensities in the range [0.,1.] .
C
C_ARGUMENTS
C
C R       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the red intensity component
C         of the input point in RGB color space.
C
C G       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the green intensity component
C         of the input point in RGB color space.
C
C B       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the blue intensity component
C         of the input point in RGB color space.
C
C Y       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] .  Y is the color component of a television
C         signal which is shown on black-and-white televisions;
C         Y minimizes the effect of two colors appearing different
C         to the human eye but mapping to similar monochrome
C         intensities.
C
C I       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [-.6,.6] .  I attains its maximum when the input triple
C         is (1.,0.,0.); I attains its minimum when the input triple
C         is (0.,1.,1.) .
C
C Q       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [-.52,.52].  Q attains its maximum when the input triple
C         is (1.,0.,1.); Q attains its minimum when the input triple
C         is (0.,1.,0.).
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    (NONE)
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    880511 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded and prepared for the
C    NCAR Graphics package by Fred Clare based on algorithms
C    in Foley and van Dam (see REFERENCES below).
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C_EXAMPLES
C    Example 1 --  Full white to YIQ.
C          SUBROUTINE TYIQ1
C          DOUBLE PRECISION    Y,I,Q,EPS
C          PARAMETER (EPS=0.01)
C          CALL RGBYIQ(1.,1.,1.,Y,I,Q)
C          IF ( (ABS(Y-1.) .GT. EPS) .OR. (ABS(I) .GT. EPS) .OR.
C         *     (ABS(Q) .GT. EPS) ) THEN
C            IUN = I1MACH(4)
C            WRITE(IUN,10)
C          ENDIF
C          RETURN
C       10 FORMAT(' TYIQ1 returned incorrect values')
C          END
C
C_END PROLOGUE RGBYIQ
C
      DOUBLE PRECISION R,G,B,Y,I,Q
C
C_FIRST EXECUTABLE STATEMENT RGBYIQ
      Y = 0.2988922D0*R + 0.5870147D0*G + 0.1140931D0*B
      I = 0.5960695D0*R - 0.2743087D0*G - 0.3217608D0*B
      Q = 0.2113775D0*R - 0.5229881D0*G + 0.3116106D0*B
C
      RETURN
      END
C
      SUBROUTINE DYIQRGB(Y,I,Q,R,G,B)
C
C_BEGIN PROLOGUE YIQRGB
C
C_PURPOSE
C    This subroutine converts a color specification given in
C    the YIQ coordinate system to the equivalent color
C    specification in the Red, Green, Blue coordinate system.
C
C_DESCRIPTION
C    This subroutine converts color values given in the
C    YIQ coordinate system to colors in the RGB coordinate
C    system.  The input value Y is in the range [0.,1.];
C    I is in the range [-.6,.6]; Q is in the range [-.52,.52].
C    The output values R, G, and B are red, green, and blue
C    intensities in the range [0.,1.] .
C
C_ARGUMENTS
C
C Y       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] .  Y is the color component of a television
C         signal which is shown on black-and-white televisions;
C         Y minimizes the effect of two colors appearing different
C         to the human eye but mapping to similar monochrome
C         intensities.
C
C I       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [-.6,.6] .
C
C Q       (INPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [-.52,.52].
C
C R       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the red intensity component
C         of the output color in RGB color space.
C
C G       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the green intensity component
C         of the output color in RGB color space.
C
C B       (OUTPUT,DOUBLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the blue intensity component
C         of the output color in RGB color space.
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    (NONE)
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    880511 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded and prepared for the
C    NCAR Graphics package by Fred Clare based on algorithms
C    in Foley and van Dam (see REFERENCES below).
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C_EXAMPLES
C    Example 1 --  Convert green from YIQ to RGB.
C          SUBROUTINE TYIQ2
C          DOUBLE PRECISION    R,G,B,EPS
C          PARAMETER (EPS=0.01)
C          CALL YIQRGB(.59,-.28,-.52,R,G,B)
C          IF ( (ABS(R-0.) .GT. EPS) .OR. (ABS(G-1.) .GT. EPS) .OR.
C         *     (ABS(B-0.) .GT. EPS) ) THEN
C            IUN = I1MACH(4)
C            WRITE(IUN,10)
C          ENDIF
C          RETURN
C       10 FORMAT(' TYIQ2 returned incorrect values')
C          END
C
C_END PROLOGUE YIQRGB
C
      DOUBLE PRECISION R,G,B,Y,I,Q
C
C  Check on the input values.
C
C_FIRST EXECUTABLE STATEMENT YIQRGB
C
      R = Y + .956D0*I + .621D0*Q
      G = Y - .272D0*I - .647D0*Q
      B = Y - 1.105D0*I + 1.702D0*Q
      R = MIN(MAX(R,0.D0),1.D0)
      G = MIN(MAX(G,0.D0),1.D0)
      B = MIN(MAX(B,0.D0),1.D0)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DSIGPLC(M1,M2,HUE)
C
C_BEGIN PROLOGUE DSIGPLC
C
C_SUBSIDIARY DHLSRGB, DHSVRGB
C
C_PURPOSE
C    To define a generic piecewise linear curve (as a function
C    of HUE) which can be used to calculate the R, G, B
C    values.
C
C_DESCRIPTION
C    This subroutine takes a minimum and maximum value and
C    defines a piecewise linear curve as a function of HUE.
C
C_ARGUMENTS
C
C M1      (INPUT,SINGLE,VARIABLE)  The minimum value.
C
C M2      (INPUT,SINGLE,VARIABLE)  The maximum value.
C
C HUE     (INPUT,SINGLE,VARIABLE)  Hue.
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    (NONE)
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    070803 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded at NCAR by Roy Barnes
C    using the algorithm presented in Foley and van Dam (see
C    REFERENCES); it was prepared for the NCAR Graphics
C    package by Fred Clare.
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C    Smith, A.R.,"Color Gamut Transformation Pairs",SIGGRAPH '78
C    Proceedings, published as Computer Graphics, 12(3),August 1978,
C    pp.12-19.
C
C_END PROLOGUE DSIGPLC
C
      DOUBLE PRECISION M1,M2,HUE,H
C_FIRST EXECUTABLE STATEMENT DSIGPLC
      H = HUE
      H = MOD(H,360.D0)
      IF (H.LT.0.D0) H = H + 360.D0
      IF (H.LT.60.0D0) THEN
C
C  Linear curve from M1 to M2 if HUE is in [0.,60.)
C
          DSIGPLC = M1 + (M2-M1)*H/60.0D0
      ELSE IF (H.LT.180.0D0) THEN
C
C  Maximum value for HUE in [60.,180.)
C
          DSIGPLC = M2
      ELSE IF (H.LT.240.0D0) THEN
C
C  Linear curve from M2 to M1 for HUE in [180.,240.)
C
          DSIGPLC = M1 + (M2-M1)* (240.0D0-H)/60.0D0
      ELSE
C
C  Minimum value for HUE in [240.,360.)
C
          DSIGPLC = M1
      END IF
C
C  Guarantee DSIGPLC is in the range 0. to 1.
C
      DSIGPLC = MIN(1.D0,MAX(0.D0,DSIGPLC))
      RETURN
      END


      include 'ttb/ttb_library.f'

      subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,
     2             nshear,disp,dispt,coord,ffn,frotn,strechn,eigvn,ffn1,
     3                   frotn1,strechn1,eigvn1,ncrd,itel,ndeg,ndm,
     4                   nnode,jtype,lclass,ifr,ifu)

      ! HYPELA2:        Nearly-Incompressible Neo-Hookean Material
      !                 Example for usage of Tensor Toolbox
      ! capability:     axisymmetric and 3D analysis
      ! Formulation:    Total Lagrange
      ! Voigt Notation: change commented Tensor Datatypes
      ! Andreas Dutzler, 2018-01-02, Graz University of Technology

      use Tensor
      implicit none

      integer :: ifr,ifu,itel,jtype,ncrd,ndeg,ndi,ndm,ngens,
     *           nn,nnode,nshear
      integer,      dimension(2)       :: m,matus,kcus,lclass
      real(kind=8), dimension(*)       :: e,de,t,dt,g,s
      real(kind=8), dimension(itel)    :: strechn,strechn1
      real(kind=8), dimension(ngens,*) :: d
      real(kind=8), dimension(ncrd,*)  :: coord
      real(kind=8), dimension(ndeg,*)  :: disp, dispt
      real(kind=8), dimension(itel,3)  :: ffn,ffn1,frotn,frotn1
      real(kind=8), dimension(itel,*)  :: eigvn,eigvn1

      type(Tensor2)  :: F1
      real(kind=8) :: J,kappa,C10

      ! to use voigt notation change to type Tensor2s, Tensor4s
      type(Tensor2) :: C1,invC1,S1,Eye
      type(Tensor4) :: C4

      ! material parameters
      C10 = 0.5
      kappa = 500.0

      Eye = identity2(Eye)
      F1 = ffn1(1:3,1:3) ! use slices (ffn1 is an assumed size array)
      J = det(F1)

      ! right cauchy-green deformation tensor and it's inverse
      C1 = transpose(F1)*F1
      invC1 = inv(C1) ! faster method: invC1 = inv(C1,J**2)

      ! pk2 stress
      S1 = 2.*C10*J**(-2./3.)*dev(C1)*invC1 + kappa*(J-1)*J*invC1

      ! material elasticity tensor
      C4 = 2.*C10 * J**(-2./3.) * 2./3. *
     *  ( tr(C1) * (invC1.cdya.invC1)
     *    - (Eye.dya.invC1) - (invC1.dya.Eye)
     *    + tr(C1)/3. * (invC1.dya.invC1) )
     *  + (kappa*(J-1)*J+kappa*J**2) * (invC1.dya.invC1)
     *  - 2.*kappa*(J-1)*J* (invC1.cdya.invC1)

      ! output as array
      s(1:ngens)         = asarray( voigt(S1), ngens )
      d(1:ngens,1:ngens) = asarray( voigt(C4), ngens, ngens )

      return
      end


PROGRAM F042

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    CHARACTER (LEN=50), PARAMETER :: FILENAME = "problems/042/p042_words.txt"
    CHARACTER (LEN=1) :: CH

    INTEGER :: COUNT_VAL =  0
    INTEGER :: INDEX_VAL = -1
    INTEGER :: WORD_VAL  =  0

    LOGICAL :: IS_INCREMENTED = .FALSE.

    REAL    :: SQRT_TERM, N_TERM

    OPEN (2, FILE = FILENAME, STATUS = 'OLD')

    READ(2, '(A1)', ADVANCE='NO', END=10) CH

    DO
        READ(2, '(A1)', ADVANCE='NO', END=10) CH

        IF ((CH >= 'A' .AND. CH <= 'Z') .OR. (CH >= 'a' .AND. CH <= 'z')) THEN

            WORD_VAL       = WORD_VAL  + IACHAR(CH) - 64
            INDEX_VAL      = INDEX_VAL + 1
            IS_INCREMENTED = .FALSE.

        ELSE

            IF (.NOT. IS_INCREMENTED) THEN

                INDEX_VAL = 0
                IS_INCREMENTED = .TRUE.

                SQRT_TERM = SQRT(1.0E0 + (8.0E0 * WORD_VAL))
                WORD_VAL = 0

                IF ((SQRT_TERM - INT(SQRT_TERM)) > 0.0) CYCLE

                N_TERM = (SQRT_TERM - 1.0) / 2.0

                IF ((N_TERM - INT(N_TERM)) > 0.0) CYCLE

                COUNT_VAL = COUNT_VAL + 1

            END IF

        END IF

    END DO

    10 CLOSE(2)

    PRINT ('(I0)'), COUNT_VAL

END PROGRAM F042


! (C) FREE-VARIABLE INEQUALITY-CONSTRAINED LINEAR PROGRAMMING
!
! (SUBPROGRAMS INVOLVED:  SLNPRO, SJELIM)
!
! GIVEN POSITIVE INTEGERS M AND N WITH M .GE. N, AND A MATRIX V, THIS
! PROGRAM WILL ATTEMPT TO SOLVE THE LINEAR PROGRAMMING PROBLEM
! MAXIMIZE  -V(M+1,1)*X(1)-...-V(M+1,N)*X(N)
! SUBJECT TO  V(I,1)*X(1)+...+V(I,N)*X(N) .LE. V(I,N+1) FOR I=1,...,M.
! ON OUTPUT, INDIC WILL BE AN ERROR FLAG WHOSE VALUE WILL BE 0 FOR A
! NORMAL SOLUTION, NEGATIVE FOR A POSSIBLY INACCURATE SOLUTION, AND
! POSITIVE FOR A PROBABLE FAILURE.  THE METHOD IS AN ENHANCED VERSION OF
! THAT IN
! AVDEYEVA, L. I. AND ZUKHOVITSKIY, S. I., LINEAR AND CONVEX PROGRAMMING,
! SAUNDERS, PHILADELPHIA, 1966.
! THE FOLLOWING SAMPLE DRIVER IS SET UP TO MAXIMIZE -Y, SUBJECT TO
! X + Y .GE. 2.0D0 (I.E. -X - Y .LE. -2.0D0) AND X - Y .LE. 4.0DO.
! (THE EXACT SOLUTION IS X = 3.0D0, Y = -1.0D0, WITH MAXIMUM OBJECTIVE
! FUNCTION VALUE 1.0D0.)
!
! SAMPLE DRIVER FOR (C) LINEAR PROGRAMMING
!
!  THE MINIMUM DIMENSIONS ARE V(NUMGR+2*NPARM+1,NPARM+2), X(NPARM+1),
!  IYCCT(NPARM+1), Y(NUMGR+2*NPARM), IXRCT(NUMGR+2*NPARM),
!  IYRCT(NUMGR+2*NPARM), WHERE NPARM .GE. N AND NUMGR .GE. M. THE FIRST
!  DIMENSION OF V MUST BE EXACTLY NUMGR+2*NPARM+1.

program main

    use conmax_module
    use iso_fortran_env, only: wp => real64

    IMPLICIT NONE

    INTEGER :: i, indic, ixrct(6), iycct(3), iyrct(6), j, m, mp1, n, &
               np1, nparm, numgr
    real(wp) :: v(7, 4), x(3), y(6)

    n = 2
    m = 2
    v(1, 1) = -1.0_wp
    v(1, 2) = -1.0_wp
    v(1, 3) = -2.0_wp
    v(2, 1) = 1.0_wp
    v(2, 2) = -1.0_wp
    v(2, 3) = 4.0_wp
    v(3, 1) = 0.0_wp
    v(3, 2) = 1.0_wp
    nparm = n
    numgr = m
    mp1 = m + 1
    np1 = n + 1
    v(mp1, np1) = 0.0_wp
    iyrct(1) = -1

    !OPEN (6,FILE='LPOUT')

    WRITE (6, 99001) m, n
99001 FORMAT(/' THERE ARE', I5, '  CONSTRAINTS AND', I5, &
           &'  VARIABLES'//' THE CONSTRAINT COEFFICIENTS AND', &
           &' RIGHT SIDES ARE')
    DO i = 1, m
        WRITE (6, 99002) (v(i, j), j=1, np1)
99002   FORMAT(/(3E22.13))
    END DO
    WRITE (6, 99003) (v(mp1, j), j=1, n)
99003 FORMAT(/' THE NEGATIVES OF THE OBJECTIVE FUNCTION', &
           &' COEFFICIENTS ARE'//(3E22.13))
    CALL SLNPRO(v, m, n, iyrct, y, ixrct, iycct, nparm, numgr, x, indic)
    WRITE (6, 99004) indic, (x(i), i=1, n)
99004 FORMAT(/' AFTER SLNPRO THE ERROR FLAG IS', I4, &
           &'  THE VARIABLES ARE'//(3E22.13))
    WRITE (6, 99005) v(mp1, np1)
99005 FORMAT(/' THE OBJECTIVE FUNCTION VALUE IS', E22.13)

END program main

! OUTPUT FOR (C) LINEAR PROGRAMMING
!
! THERE ARE    2  CONSTRAINTS AND    2  VARIABLES
!
! THE CONSTRAINT COEFFICIENTS AND RIGHT SIDES ARE
!
!  -0.1000000000000E+01  -0.1000000000000E+01  -0.2000000000000E+01
!
!   0.1000000000000E+01  -0.1000000000000E+01   0.4000000000000E+01
!
! THE NEGATIVES OF THE OBJECTIVE FUNCTION COEFFICIENTS ARE
!
!   0.0000000000000E+00   0.1000000000000E+01
!
! AFTER SLNPRO THE ERROR FLAG IS   0  THE VARIABLES ARE
!
!   0.3000000000000E+01  -0.1000000000000E+01
!
! THE OBJECTIVE FUNCTION VALUE IS   0.1000000000000E+01


module mod_diff

  ! Finite difference functions.

  use iso_fortran_env, only: int32, real32
  implicit none

  private
  public :: diffx, diffy

contains

  pure function diffx(x) result(dx)
    ! Centered finite difference in x.
    real(real32), intent(in) :: x(:,:)
    real(real32) :: dx(size(x, dim=1), size(x, dim=2))
    integer(int32) :: i, im
    im = size(x, dim=1)
    dx = 0
    dx(2:im-1,:) = 0.5 * (x(3:im,:) - x(1:im-2,:))
  end function diffx

  pure function diffy(x) result(dx)
    ! Centered finite difference in y.
    real(real32), intent(in) :: x(:,:)
    real(real32) :: dx(size(x, dim=1), size(x, dim=2))
    integer(int32) :: j, jm
    jm = size(x, dim=2)
    dx = 0
    dx(:,2:jm-1) = 0.5 * (x(:,3:jm) - x(:,1:jm-2))
  end function diffy

end module mod_diff


    subroutine ktsol(n,ns,nv,a,b,x,ktilt,maxeq)
!-----------------------------------------------------------------------

! Solution of a system of linear equations by gaussian elimination with
! partial pivoting.  Several right hand side matrices and several
! variables are allowed.

!         NOTE: All input matrices must be in double precision

! INPUT/OUTPUT VARIABLES:

!   n                Number of equations
!   ns               Number of right hand side matrices
!   nv               Number of variables.
!   a(n*n*nv)        left hand side matrices versus columnwise.
!   b(n*ns*nv)       input right hand side matrices.
!   x(n*ns*nv)       solution matrices.
!   ktilt            indicator of singularity
!                      =  0  everything is ok.
!                      = -1 n.le.1
!                      =  k  a null pivot appeared at the kth iteration.
!   tol              used in test for null pivot. depends on machine
!                      precision and can also be set for the tolerance
!                      of an ill-defined kriging system.

!-----------------------------------------------------------------------
    implicit real*8 (a-h,o-z)
    real*8 :: x(maxeq),a(maxeq*maxeq),b(maxeq)

! Make sure there are equations to solve:

    if(n <= 1) then
        ktilt = -1
        return
    endif

! Initialization:

    tol   = 0.1e-10
    ktilt = 0
    ntn   = n*n
    nm1   = n-1

! Triangulation is done variable by variable:

    do iv=1,nv

    ! Indices of location in vectors a and b:

        nva = ntn*(iv-1)
        nvb = n*ns*(iv-1)

    ! Gaussian elimination with partial pivoting:

        do k=1,nm1
            kp1 = k+1

        ! Indice of the diagonal element in the kth row:

            kdiag = nva+(k-1)*n+k

        ! Find the pivot - interchange diagonal element/pivot:

            npiv = kdiag
            ipiv = k
            i1   = kdiag
            do i=kp1,n
                i1 = i1+1
                if(abs(a(i1)) > abs(a(npiv))) then
                    npiv = i1
                    ipiv = i
                endif
            end do
            t        = a(npiv)
            a(npiv)  = a(kdiag)
            a(kdiag) = t

        ! Test for singularity:

            if(abs(a(kdiag)) < tol) then
                ktilt=k
                return
            endif

        ! Compute multipliers:

            i1 = kdiag
            do i=kp1,n
                i1    = i1+1
                a(i1) = -a(i1)/a(kdiag)
            end do

        ! Interchange and eliminate column per column:

            j1 = kdiag
            j2 = npiv
            do j=kp1,n
                j1    = j1+n
                j2    = j2+n
                t     = a(j2)
                a(j2) = a(j1)
                a(j1) = t
                i1    = j1
                i2    = kdiag
                do i=kp1,n
                    i1    = i1+1
                    i2    = i2+1
                    a(i1) = a(i1)+a(i2)*a(j1)
                end do
            end do

        ! Interchange and modify the ns right hand matrices:

            i1 = nvb+ipiv
            i2 = nvb+k
            do i=1,ns
                t     = b(i1)
                b(i1) = b(i2)
                b(i2) = t
                j1    = i2
                j2    = kdiag
                do j=kp1,n
                    j1    = j1+1
                    j2    = j2+1
                    b(j1) = b(j1)+b(i2)*a(j2)
                end do
                i1 = i1+n
                i2 = i2+n
            end do
        end do

    ! Test for singularity for the last pivot:

        kdiag = ntn*iv
        if(abs(a(kdiag)) < tol) then
            ktilt = n
            return
        endif
    end do

! End of triangulation. Now, solve back variable per variable:

    do iv=1,nv

    ! Indices of location in vectors a and b:

        nva  = ntn*iv
        nvb1 = n*ns*(iv-1)+1
        nvb2 = n*ns*iv

    ! Back substitution with the ns right hand matrices:

        do il=1,ns
            do k=1,nm1
                nmk = n-k

            ! Indice of the diagonal element of the (n-k+1)th row and of
            ! the (n-k+1)th element of the left hand side.

                kdiag = nva-(n+1)*(k-1)
                kb    = nvb2-(il-1)*n-k+1
                b(kb) = b(kb)/a(kdiag)
                t     = -b(kb)
                i1    = kb
                i2    = kdiag
                do i=1,nmk
                    i1    = i1-1
                    i2    = i2-1
                    b(i1) = b(i1)+a(i2)*t
                end do
            end do
            kdiag = kdiag-n-1
            kb    = kb-1
            b(kb) = b(kb)/a(kdiag)
        end do

    ! End of back substitution:

    end do

! Restitution of the solution:

    itot = n*ns*nv
    do i=1,itot
        x(i) = b(i)
    end do

! Finished:

    return
    end subroutine ktsol


!====================================================
SUBROUTINE splper(n,h,y,bi,ci,di)

! Makes a cubic spline of periodic function y(x)
!
! Input:  n                   number of values in y
!         h                   step size in x (aequidistant)
!         y(n)                y-values
! Output: bi(n),ci(n),di(n)   Spline parameters

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                     INTENT(in)  :: n
  REAL(kind=dp),               INTENT(in)  :: h
  REAL(kind=dp), DIMENSION(n), INTENT(in)  :: y
  REAL(kind=dp), DIMENSION(n), INTENT(out) :: bi, ci, di

  REAL(kind=dp)                            :: psi, ss
  REAL(kind=dp), DIMENSION(:), ALLOCATABLE :: bmx, yl
  REAL(kind=dp), DIMENSION(:), ALLOCATABLE :: amx1, amx2, amx3
  INTEGER                                  :: nmx, n1, n2, i, i1

  ALLOCATE ( bmx(n), yl(n), amx1(n), amx2(n), amx3(n) )

  bmx(1) = 1.e30_dp

  nmx=n-1
  n1=nmx-1
  n2=nmx-2
  psi=3.0_dp/h/h

  CALL spfper(n,amx1,amx2,amx3)

  bmx(nmx) = (y(nmx+1)-2*y(nmx)+y(nmx-1))*psi
  bmx(1)   =(y(2)-y(1)-y(nmx+1)+y(nmx))*psi
  DO i = 3,nmx
     bmx(i-1) = (y(i)-2*y(i-1)+y(i-2))*psi
  END DO
  yl(1) = bmx(1)/amx1(1)
  DO i = 2,n1
     i1 = i-1
     yl(i) = (bmx(i)-yl(i1)*amx2(i1))/amx1(i)
  END DO
  ss = 0
  DO i = 1,n1
     ss = ss+yl(i)*amx3(i)
  END DO
  yl(nmx) = (bmx(nmx)-ss)/amx1(nmx)
  bmx(nmx) = yl(nmx)/amx1(nmx)
  bmx(n1) = (yl(n1)-amx2(n1)*bmx(nmx))/amx1(n1)
  DO i = n2,1,-1
     bmx(i) = (yl(i)-amx3(i)*bmx(nmx)-amx2(i)*bmx(i+1))/amx1(i)
  END DO
  DO i = 1,nmx
     ci(i) = bmx(i)
  END DO

  DO i = 1,n1
     bi(i) = (y(i+1)-y(i))/h-h*(ci(i+1)+2*ci(i))/3
     di(i) = (ci(i+1)-ci(i))/h/3
  END DO
  bi(nmx) = (y(n)-y(n-1))/h-h*(ci(1)+2*ci(nmx))/3
  di(nmx) = (ci(1)-ci(nmx))/h/3
!
! Fix of problems at upper periodicity boundary
!
  bi(n) = bi(1)
  ci(n) = ci(1)
  di(n) = di(1)

  DEALLOCATE ( bmx, yl, amx1, amx2, amx3 )

  RETURN
END SUBROUTINE splper


program TestSHExpandLSQ
!------------------------------------------------------------------------------
!
!    This program will (1) create a set of unevenly spaced data points from a
!    spherical harmonic file, and then (2) expand these into spherical
!    harmonics using a least-squares inversion if there are more data points
!    than spherical harmonic coefficients (overdetermined case), or using a
!    minimum norm solution if there are more coefficients than data points
!    (underdetermined case).
!
!    Copyright (c) 2005, SHTOOLS
!    All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS
    use ftypes

    implicit none

    integer, parameter :: dmax = 10000, degmax = 120
    real(dp) :: d(dmax), lat(dmax), lon(dmax), cilm(2,degmax+1, degmax+1), &
                x, y, z, pi, maxerror, cilm1(2,degmax+1, degmax+1), &
                dd(dmax), misfit
    integer :: nmax, lmax, l, i, seed, lmaxfile
    character(80) :: infile

    d = 0.0_dp
    dd = 0.0_dp
    lon = 0.0_dp
    lat = 0.0_dp
    pi = acos(-1.0_dp)

    infile = "../../ExampleDataFiles/MarsTopo719.shape"

    call SHRead(infile, cilm, lmaxfile)
    print*, "Maximum degree of spherical harmonic file = ", lmaxfile

    print*, "Number of random data points to use > "
    read(*,*) nmax
    lmax = floor(sqrt(dble(nmax)) - 1)
    print*, "Maximum spherical harmonic degree for overdetermined least-squares inversion = ", lmax

    !--------------------------------------------------------------------------
    !
    !    Create synthetic data from the known spherical harmonic coefficients.
    !    Data points are located at random points on the sphere.
    !
    !--------------------------------------------------------------------------

    seed = -13453

    do i = 1, nmax
        x = 2.0_dp * RandomN(seed) - 1.0_dp
        y = 2.0_dp * RandomN(seed) - 1.0_dp
        z = 2.0_dp * RandomN(seed) - 1.0_dp
        lat(i) = atan2(z, sqrt(x**2 + y**2)) * 180.0_dp  /pi
        lon(i) = atan2(y, x) * 180.0_dp / pi
        d(i) = MakeGridPoint(cilm, lmaxfile, lat(i), lon(i), norm=1)
    end do

    print*, "maximum (km) = ", maxval(d(1:nmax)) / 1.e3_dp
    print*, "minimum (km) = ", minval(d(1:nmax)) / 1.e3_dp

    !--------------------------------------------------------------------------
    !
    !    Do least squares inversion for increasing values of l.
    !
    !--------------------------------------------------------------------------

    do l = 1, lmax, 1

        print*, "l = ", l

        call SHExpandLSQ(cilm1, d(1:nmax), lat(1:nmax), lon(1:nmax), nmax, &
                         l, norm=1, chi2=misfit)

        do i = 1, nmax
            dd(i) = MakeGridPoint(cilm1, l, lat(i), lon(i), norm=1)
        end do

        maxerror = maxval(abs(d(1:nmax) - dd(1:nmax)))

        print*, "Maximum error between input and output data points (km) = ", maxerror / 1.e3_dp
        print*, "Sum of squares residuals (km^2) = ", misfit / 1.e6_dp

    end do

end program TestSHExpandLSQ


*
      SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
     $                  INFO )
*
*  -- LAPACK driver routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*  -- Modified by R. Clint Whaley for ATLAS Fortran77 LAPACK interface, 2010
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS
*     ..
*     .. Array Arguments ..
      REAL   A( LDA, * ), B( LDB, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  SGELS solves overdetermined or underdetermined real linear systems
*  involving an M-by-N matrix A, or its transpose, using a QR or LQ
*  factorization of A.  It is assumed that A has full rank.
*
*  The following options are provided:
*
*  1. If TRANS = 'N' and m >= n:  find the least squares solution of
*     an overdetermined system, i.e., solve the least squares problem
*                  minimize || B - A*X ||.
*
*  2. If TRANS = 'N' and m < n:  find the minimum norm solution of
*     an underdetermined system A * X = B.
*
*  3. If TRANS = 'T' and m >= n:  find the minimum norm solution of
*     an undetermined system A**T * X = B.
*
*  4. If TRANS = 'T' and m < n:  find the least squares solution of
*     an overdetermined system, i.e., solve the least squares problem
*                  minimize || B - A**T * X ||.
*
*  Several right hand side vectors b and solution vectors x can be
*  handled in a single call; they are stored as the columns of the
*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
*  matrix X.
*
*  Arguments
*  =========
*
*  TRANS   (input) CHARACTER*1
*          = 'N': the linear system involves A;
*          = 'T': the linear system involves A**T.
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of
*          columns of the matrices B and X. NRHS >=0.
*
*  A       (input/output) REAL array, dimension (LDA,N)
*          On entry, the M-by-N matrix A.
*          On exit,
*            if M >= N, A is overwritten by details of its QR
*                       factorization as returned by DGEQRF;
*            if M <  N, A is overwritten by details of its LQ
*                       factorization as returned by DGELQF.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  B       (input/output) REAL array, dimension (LDB,NRHS)
*          On entry, the matrix B of right hand side vectors, stored
*          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
*          if TRANS = 'T'.
*          On exit, if INFO = 0, B is overwritten by the solution
*          vectors, stored columnwise:
*          if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
*          squares solution vectors; the residual sum of squares for the
*          solution in each column is given by the sum of squares of
*          elements N+1 to M in that column;
*          if TRANS = 'N' and m < n, rows 1 to N of B contain the
*          minimum norm solution vectors;
*          if TRANS = 'T' and m >= n, rows 1 to M of B contain the
*          minimum norm solution vectors;
*          if TRANS = 'T' and m < n, rows 1 to M of B contain the
*          least squares solution vectors; the residual sum of squares
*          for the solution in each column is given by the sum of
*          squares of elements M+1 to N in that column.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B. LDB >= MAX(1,M,N).
*
*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.
*          LWORK >= max( 1, MN + max( MN, NRHS ) ).
*          For optimal performance,
*          LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
*          where MN = min(M,N) and NB is the optimum block size.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO =  i, the i-th diagonal element of the
*                triangular factor of A is zero, so that A does not have
*                full rank; the least squares solution could not be
*                computed.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER ATLASROWMAJOR, ATLASCOLMAJOR
      PARAMETER (ATLASROWMAJOR=101, ATLASCOLMAJOR=102)
      INTEGER ATLASNOTRANS, ATLASTRANS, ATLASCONJTRANS
      PARAMETER (ATLASNOTRANS=111, ATLASTRANS=112, ATLASCONJTRANS=113)
      INTEGER ATLASUPPER, ATLASLOWER
      PARAMETER (ATLASUPPER=121, ATLASLOWER=122)
      INTEGER ATLASNONUNIT, ATLASUNIT
      PARAMETER (ATLASNONUNIT=131, ATLASUNIT=132)
      INTEGER ATLASLEFT, ATLASRIGHT
      PARAMETER (ATLASLEFT=141, ATLASRIGHT=142)
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            ITRANS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           ATL_F77WRAP_SGELS, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments.
*
      INFO = 0
      MN = MIN( M, N )
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.-1 )THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGELS ', -INFO )
         RETURN
      END IF
*
      IF (LSAME(TRANS, 'N')) THEN
         ITRANS = ATLASNOTRANS
      ELSE
         ITRANS = ATLASTRANS
      END IF
*
      CALL ATL_F77WRAP_SGELS(ITRANS, M, N, NRHS, A, LDA, B, LDB,
     $                       WORK, LWORK, INFO)
*
*     End of SGELS
*
      END


integer, parameter   :: n = 3, m = 5
real, dimension(n,m) :: a = reshape( (/ (i,i=1,n*m) /), (/ n, m /) )
real, dimension(m,n) :: b

b = transpose(a)

do i = 1, n
    print *, a(i,:)
end do

do j = 1, m
    print *, b(j,:)
end do


subroutine read_oceanic_temperature(IOunit, co2_axis, Toceclimber)

    implicit none
    include 'shape.inc'
    integer, intent(in) :: IOunit
    double precision, dimension(nclimber), intent(in) :: co2_axis
    double precision, dimension(nbasin, nclimber), intent(out) :: Toceclimber
    double precision, dimension(nclimber) :: SST, deepT
    double precision :: co2
    integer :: k
    character(len=10) :: line

    ! Try reading temperature generating mode (string) in input file
    read(unit=IOunit, fmt=*) line

    if (line == 'parametric') then

        ! Parametric CO2-temperature relationship
        ! ---------------------------------------

        !SST = 15. !6.8161*dlog(co2_axis*280.) - 22.089

        ! Pre-industrial
        SST = 20 + 4.88504*dlog(co2_axis)
        deepT = -6.58807 + 6.89026*dlog(co2_axis)
        ! Fixed oceanic temperature
        !SST = 20
        !deepT = -6.58807

        ! 265Ma
        !SST = 15.6279 + 4.88504*dlog(co2_axis)
        !deepT = -6.58807 + 6.89026*dlog(co2_axis)

        ! 365Ma
        !SST = 12.5071 + 5.98331*dlog(co2_axis)
        !deepT = -30.8490 + 16.9424*dlog(co2_axis)

        ! -----------------------------------------------------
        ! SURFACE:
        Toceclimber(1,:) = deepT  !SST-18
        Toceclimber(3,:) = SST
        Toceclimber(6,:) = SST
        Toceclimber(8,:) = deepT  !SST-18

        ! -----------------------------------------------------
        ! DEEP
        Toceclimber(2,:) = deepT
        Toceclimber(4,:) = deepT
        Toceclimber(5,:) = deepT
        Toceclimber(7,:) = Toceclimber(6,:)
        Toceclimber(9,:) = deepT

    else

      ! if input file does not contain the word "parametric",
      ! expect direct temperature reading, one CO2 level per line, in DECREASING order.

      rewind(IOunit)

      do k = nclimber,1,-1
          read(unit=IOunit, fmt=*) co2, Toceclimber(1:nbasin-1,k)
          !                   skip atmosphere box --^^^^^^^^^^
          if (abs(co2/280. - co2_axis(k)) > 1d-6) then
              print *
              print *, 'Error while reading oceanic temperature'
              print *, 'CO2 mismatch for level #', k
              write(*, fmt='(A,F10.2,A,F10.2)') 'Got: ', real(co2), ', expect: ', 280*co2_axis(k)
              stop
          end if
      end do

    end if

    ! Security: avoid too low oceanic temperature because it makes the chemistry routines crash
    where (Toceclimber(1:nbasin-1,:) <= 1)  Toceclimber(1:nbasin-1,:) = 1d0

    ! Temperature conversion: deg C => Kelvin
    Toceclimber(1:nbasin-1,:) = Toceclimber(1:nbasin-1,:) + 273.15

    close(unit=IOunit)

end subroutine


      subroutine statd(n,x,mean,sd,sk,c4,c6,max,min,io)
c**************************************************
c     Version : 9-14-2005
c     Precision : single precision out/double arithmetic
c     Function : Calculates mean, standard deviation, skewness - sk,
c      kurtosis - c4, 6-th order cumulant - c6, maximum - max, and
c      minimum - min of the sample.
c=================================================
      real*8 s1,s2,s3,s4,s6,dx,dx3,dmn,dn,ds,xmin,xmax
      real x(n),mean,max,min
      intent(in) n,x,io
      intent(out) mean,sd,sk,c4,c6,max,min
c**************************************************
c  Initialize accumulators
      xmax=x(1)
      xmin=x(1)
      s1=0.d0
      s2=0.d0
      s3=0.d0
      s4=0.d0
      s6=0.d0
      dn=dfloat(n)
      do k=1,n
       dx=dble(x(k))
       xmax=dmax1(dx,xmax)
       xmin=dmin1(dx,xmin)
c  Sum x
       s1=s1+dx
c  Sum x*x
       s2=s2+dx*dx
      enddo
      max=xmax
      min=xmin
c  Mean
      dmn=s1/dn
      mean=sngl(dmn)
c  Sum(x*x)-Sum(x)*Sum(x)/n
      s2=s2-dmn*s1
c  Check if variance=0
      if(s2<=0.d0) then
       write(io,*) 'Variance ',sngl(s2),' in STAT = 0 & is set = -1'
       sd=-1.0
       return
      endif
c  Check if variance<1.d-5
      if(s2<=1.d-5) then
       s2=0.d0
       do k=1,n
        dx=dble(x(k))-dmn
        s2=s2+dx*dx
       enddo
      endif
c  Compute standard deviation
      ds=dsqrt(s2/dfloat(n-1))
      sd=sngl(ds)
c  Compute other stats
      do k=1,n
       dx=dble(x(k))-dmn
       dx3=dx*dx*dx
       s3=s3+dx3
       s4=s4+dx3*dx
       s6=s6+dx3*dx3
      enddo
      dx3=ds*ds*ds
      s3=s3/(dn*dx3)
      sk=sngl(s3)
      s4=s4/(dn*dx3*ds)-3.d0
      c4=sngl(s4)
      s6=s6/(dx3*dx3)
      c6=sngl(s6/dn-15.d0*s4-10.d0*s3*s3-15.d0)
c-------
      return
      end


      SUBROUTINE TRIDI2T3(L,N,CL,CM,CU,R1,R2,AU,A1,A2)
!
      USE MACHINE , ONLY : kind_phys
      implicit none
      integer   L,N
!
      real(kind=kind_phys)
     &          CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N),
     &          AU(L,N-1),A1(L,N),A2(L,N)
!
      real(kind=kind_phys) fk
      integer              k,i
!
      DO I=1,L
        FK      = 1. / CM(I,1)
        AU(I,1) = FK*CU(I,1)
        A1(I,1) = FK*R1(I,1)
        A2(I,1) = FK*R2(I,1)
      ENDDO
      DO K=2,N-1
        DO I=1,L
          FK      = 1./(CM(I,K)-CL(I,K)*AU(I,K-1))
          AU(I,K) = FK*CU(I,K)
          A1(I,K) = FK*(R1(I,K)-CL(I,K)*A1(I,K-1))
          A2(I,K) = FK*(R2(I,K)-CL(I,K)*A2(I,K-1))
        ENDDO
      ENDDO
      DO I=1,L
        FK      = 1./(CM(I,N)-CL(I,N)*AU(I,N-1))
        A1(I,N) = FK*(R1(I,N)-CL(I,N)*A1(I,N-1))
        A2(I,N) = FK*(R2(I,N)-CL(I,N)*A2(I,N-1))
      ENDDO
      DO K=N-1,1,-1
        DO I=1,L
          A1(I,K) = A1(I,K) - AU(I,K)*A1(I,K+1)
          A2(I,K) = A2(I,K) - AU(I,K)*A2(I,K+1)
        ENDDO
      ENDDO
!-----------------------------------------------------------------------
      RETURN
      END


program testMatrix
    use Matrix
    implicit none
    integer :: i, j, N, M, P
    real :: A(2, 3) = reshape((/1, 3, 2, 4, 1, 2/), (/2, 3/))
    real :: B(3, 2) = reshape((/1, 2, 1, 0, 2, 3/), (/3, 2/))
    real :: D(2, 2) = reshape((/1, 3, 2, 4/), (/2, 2/))
    real :: C(2, 2)
    real :: X(2) = (/2, 3/)

    N = size(A, 1)
    M = size(A, 2)
    P = size(B, 2)
    call matrix_mult(A, B, C)
    write(*, *) ((C(i, j), j=1, P), i=1, N)

    ! ---
    C = A .x. B
    write(*, *) ((C(i, j), j=1, P), i=1, N)
    write(*, "(2f3.0)") X
    X = D .x. X
    write(*, "(2f3.0)") X

end program testMatrix


      PROGRAM xchebev
C     driver for routine chebev
      INTEGER NVAL
      REAL PIO2
      PARAMETER(NVAL=40, PIO2=1.5707963)
      INTEGER i,mval
      REAL a,b,chebev,func,x,c(NVAL)
      EXTERNAL func
      a=-PIO2
      b=PIO2
      call chebft(a,b,c,NVAL,func)
C     test Chebyshev evaluation routine
10    write(*,*) 'How many terms in Chebyshev evaluation?'
      write(*,'(1x,a,i2,a)') 'Enter n between 6 and ',NVAL,
     *     '. Enter n=0 to END.'
      read(*,*) mval
      if ((mval.le.0).or.(mval.gt.NVAL)) goto 20
      write(*,'(1x,t10,a,t19,a,t28,a)') 'X','Actual','Chebyshev fit'
      do 11 i=-8,8,1
        x=i*PIO2/10.0
        write(*,'(1x,3f12.6)') x,func(x),chebev(a,b,c,mval,x)
11    continue
      goto 10
20    END
      REAL FUNCTION func(x)
      REAL x
      func=(x**2)*(x**2-2.0)*sin(x)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xchebev.for


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This program compares the performances of the matrix multiplication
! implemented in terms of i) a triple do-loop; ii) a fortran intrinsic
! function - matmul(a,b); and iii) a subroutine in INTEL MKL - ?GEMM.
program test
  implicit none
  ! The order of the square matrices is 2000.
  integer(kind=4)::n=2000
  ! Calculate the matrix multiplications:
  ! i) c:=a*b in a triple do-loop.
  ! ii) d:=a*b by matmul(a,b).
  ! iii) e:=a*b by dgemm in INTEL MKL.
  real(kind=8),allocatable::a(:,:),b(:,:),c(:,:),d(:,:),e(:,:)
  real(kind=8)::alpha,beta
  integer(kind=4)::i,j,k,lda,ldb,lde
  real(kind=8)::start,finish

  allocate(a(n,n),b(n,n),c(n,n),d(n,n),e(n,n))
  alpha=1.0;beta=1.0
  lda=n;ldb=n;lde=n

  ! Generate the matrices, a and b, randomly.
  call cpu_time(start)
  call random_seed()
  do j=1, n
     do i=1, n
        call random_number(a(i,j))
        call random_number(b(i,j))
     end do
  end do
  call cpu_time(finish)
  write(unit=6,fmt=100) "The generation of two matrices takes ",finish-start," seconds."

  ! i) c:=a*b in a triple do-loop.
  call cpu_time(start)
  c=0.0D0
  do j=1, n
     do i=1, n
        do k=1, n
           c(i,j)=c(i,j)+a(i,k)*b(k,j)
        enddo
     enddo
  enddo
  call cpu_time(finish)
  write(unit=6,fmt=100) "A triple do-loop takes ",finish-start," seconds."
  print *,c(1000,1000)

  ! ii) d:=a*b by matmul(a,b).
  call cpu_time(start)
  d=0.0D0
  d=matmul(a,b)
  call cpu_time(finish)
  write(unit=6,fmt=100) "A matmul(a,b) function takes ",finish-start," seconds."
  print *,d(1000,1000)

  ! iii) e:=a*b by dgemm in INTEL MKL.
  call cpu_time(start)
  e=0.0D0
  call dgemm("N","N",n,n,n,alpha,a,lda,b,ldb,beta,e,lde)
  call cpu_time(finish)
  write(unit=6,fmt=100) "A DGEMM subroutine takes ",finish-start," seconds."
  print *,e(1000,1000)

  deallocate(a,b,c,d,e)

  stop
100 format(A,F8.3,A)
end program test


program main
  use numeric_kinds, only: dp
  use davidson, only: generalized_eigensolver
  use array_utils, only: generate_diagonal_dominant
  use test_utils, only:  write_matrix, write_vector

  implicit none

  integer, parameter :: dim = 50
  integer, parameter :: lowest = 3
  real(dp), dimension(3) :: eigenvalues_DPR, eigenvalues_GJD, eigenvalues_DPR_gen, eigenvalues_GJD_gen
  real(dp), dimension(dim, 3) :: eigenvectors_DPR, eigenvectors_GJD, eigenvectors_DPR_gen, eigenvectors_GJD_gen
  real(dp), dimension(dim, dim) ::  mtx, stx
  integer :: iter_i

  ! mtx = read_matrix("tests/matrix.txt", 100)
  mtx = generate_diagonal_dominant(dim, 1d-3)

  ! call eigenvalue solver
  call generalized_eigensolver(mtx, eigenvalues_GJD, eigenvectors_GJD, lowest, "GJD", 1000, 1d-8, iter_i)
  call generalized_eigensolver(mtx, eigenvalues_DPR, eigenvectors_DPR, lowest, "DPR", 1000, 1d-8, iter_i)

  call write_matrix("test_dense_spec_matrix.txt", mtx)
  call write_vector("test_dense_spec_eigenvalues_GJD.txt",eigenvalues_GJD)
  call write_vector("test_dense_spec_eigenvalues_DPR.txt",eigenvalues_DPR)
  call write_matrix("test_dense_spec_eigenvectors_GJD.txt", eigenvectors_GJD)
  call write_matrix("test_dense_spec_eigenvectors_DPR.txt", eigenvectors_DPR)

  ! call generalized eigenvalue solver
  stx = generate_diagonal_dominant(dim, 1d-3, 1d0)
  call generalized_eigensolver(mtx, eigenvalues_GJD_gen, eigenvectors_GJD_gen, lowest, "GJD", 1000, 1d-8, iter_i, 10, stx)
  call generalized_eigensolver(mtx, eigenvalues_DPR_gen, eigenvectors_DPR_gen, lowest, "DPR", 1000, 1d-8, iter_i, 10, stx)

  call write_matrix("test_dense_gen_matrix.txt", mtx)
  call write_matrix("test_dense_gen_stx.txt", stx)
  call write_vector("test_dense_gen_eigenvalues_GJD.txt",eigenvalues_GJD_gen)
  call write_vector("test_dense_gen_eigenvalues_DPR.txt",eigenvalues_DPR_gen)
  call write_matrix("test_dense_gen_eigenvectors_GJD.txt", eigenvectors_GJD_gen)
  call write_matrix("test_dense_gen_eigenvectors_DPR.txt", eigenvectors_DPR_gen)

end program main