MODULE m_anglso
contains
  COMPLEX FUNCTION anglso(theta,phi,l1,m1,is1,l2,m2,is2,compo)
    USE m_juDFT
    USE m_constants
    !
    ! calculates spin-orbit matrix for theta,phi =/= 0
    !
    IMPLICIT NONE
    !     ..
    !     .. Scalar Arguments ..
    INTEGER, INTENT(IN) :: is1,is2,l1,l2,m1,m2
    INTEGER, INTENT(IN),OPTIONAL :: compo
    REAL,    INTENT(IN) :: theta,phi
    !     ..
    !     .. Local Scalars ..
    REAL sgm1,sgm2,xlz,xlpl,xlmn,angl_r,angl_i
    LOGICAL :: l_standard_euler_angles

    anglso = CMPLX(0.0,0.0)
    IF (l1.NE.l2) THEN
       RETURN
    ENDIF
    !

    l_standard_euler_angles=.FALSE.

    sgm1 = is1
    sgm2 = is2
    IF (l1.LT.0) THEN
       WRITE (oUnit,FMT=*) ' PROGRAM STOPS IN ANGLSO ( L < 0 ) .'
       WRITE (oUnit,FMT=*) ' L1 =',l1,'    L2 =',l2
       CALL juDFT_error("ANGLSO (L <0 )",calledby="anglso")
    ELSE IF ((ABS(m1).GT.l1) .OR. (ABS(m2).GT.l2)) THEN
       WRITE (oUnit,FMT=*) ' PROGRAM STOPS IN ANGLSO ( M < L OR L < M )'
       WRITE (oUnit,FMT=*) ' L1 =',l1,'    L2 =',l2
       WRITE (oUnit,FMT=*) ' M1 =',m1,'    M2 =',m2
       CALL juDFT_error("ANGLSO ( M < L OR L < M )",calledby="anglso")
    ELSE IF ((is1.NE.-1.AND.is1.NE.1) .OR. (is2.NE.-1.AND.is2.NE.1)) THEN
       WRITE (oUnit,FMT=*) ' PROGRAM STOPS IN ANGLSO ( S >< +-1/2 ) .'
       WRITE (oUnit,FMT=*) ' S1 =',0.5*sgm1,'    S2 =',0.5*sgm2
       CALL juDFT_error("ANGLSO ( S >< +-1/2 )",calledby ="anglso")
    END IF
    !
    ! lz,l+,l-
    !
    xlz = 0.0
    xlpl= 0.0
    xlmn= 0.0
    ! is1.eq.is2-2 -> <-| |+> => l+
    IF (m1.EQ.m2+1) THEN
       xlpl = SQRT(REAL((l2-m2)* (l2+m2+1)))
       ! is1.eq.is2+2 -> <+| |-> => l-
    ELSE IF (m1.EQ.m2-1) THEN
       xlmn = SQRT(REAL((l2+m2)* (l2-m2+1)))
       ! is1.eq.is2 -> <+| |+> => lz
    ELSE IF (m1.EQ.m2  ) THEN
       xlz  = m2
    END IF

    IF(PRESENT(compo))THEN
!      Used for the wannier-interpolation of SOC:
!      wann_socmat_vec allow us to
!      add SOC during the wannier-interpolation.
!      Therefore, theta and phi are specified during the
!      Wannier-interpolation step and not here.
!      Therefore, write out only xlz, xlpl, and xlmn and RETURN
!      afterwards, without using theta and phi.
!      xlz, xlpl and xlmn are needed in subroutine wann_socmat_vec.F
       if(compo.eq.1)then
          anglso = CMPLX(xlz,0.0)
       elseif(compo.eq.2)then
          anglso = CMPLX(xlmn,0.0)
       elseif(compo.eq.3)then
          anglso = CMPLX(xlpl,0.0)
       else
         CALL juDFT_error("maucompo",calledby ="anglso")
       endif
       RETURN
    END IF

    !
    ! rotated spin-orbit angular matrix
    ! <1| |1> or <2| |2>
    !

    !     If l_standard_euler_angles is set to .false., the old version
    !     of this subroutine is used, which works fine if only MAE is
    !     needed. In the old version, theta and phi specify the direction
    !     of spin quantization. However, there remains the degree of freedom
    !     of rotation around the spin quantization direction. The new version
    !     of this subroutine, which is switched on by setting l_standard_euler_angles
    !     to true, rotates x, y and z axes first by phi around z counterclockwisely
    !     and then the resulting axes x', y' and z' by theta around y'
    !     counterclockwisely to obtain the final coordinate frame x'', y'' and z''.
    !     This new version is useful when one is interested also in the spin
    !     perpendicular to the spin quantization axis. The old version seems to be
    !     different from the new one as follows when theta and phi differ from zero:
    !     x''_old = -x''_new
    !     y''_old = -y''_new
    !     z''_old = z''
    !     If theta and phi are zero, there is no difference, leading thus to a
    !     discontinuous Euler transformation in the old version and a continuous
    !     transformation in the new version.
    !     Both versions do not differ for MAE, but if the standard Pauli matrix
    !     is used to obtain x or y components of spin, the spin is discontinuous
    !     in the old version as a function of theta and phi.

    IF(l_standard_euler_angles)THEN

       IF (is1.EQ.is2) THEN
          angl_r = isign(1,is1) * ( COS(theta)*xlz +&
               &                          0.5*SIN(theta)*COS(phi)*(xlmn + xlpl) )
          angl_i = isign(1,is1)*0.5*SIN(theta)*SIN(phi)*(xlmn - xlpl)
          ! <1| |2>
       ELSEIF (is1.EQ.is2+2) THEN
          angl_r =  - SIN(theta)*xlz +  COS(phi)*(&
               &             COS(theta/2.)**2 * xlmn - SIN(theta/2.)**2 * xlpl )
          angl_i = SIN(phi)*( &
               &              COS(theta/2.)**2 * xlmn + SIN(theta/2.)**2 * xlpl )
          ! <2| |1>
       ELSEIF (is1.EQ.is2-2) THEN
          angl_r = - SIN(theta)*xlz +  COS(phi)*(&
               &            + COS(theta/2.)**2 * xlpl - SIN(theta/2.)**2 * xlmn )
          angl_i =  SIN(phi)*( &
               &             - COS(theta/2.)**2 * xlpl - SIN(theta/2.)**2 * xlmn )
       ELSE
          angl_r = 0.0
          angl_i = 0.0
       ENDIF

    ELSE
       IF (is1.EQ.is2) THEN
          angl_r = isign(1,is1) * ( COS(theta)*xlz +&
               &                          0.5*SIN(theta)*COS(phi)*(xlmn + xlpl) )
          angl_i = isign(1,is1)*0.5*SIN(theta)*SIN(phi)*(xlmn - xlpl)
          ! <1| |2>
       ELSEIF (is1.EQ.is2+2) THEN
          angl_r =  SIN(theta)*xlz +  COS(phi)*(&
               &            - COS(theta/2.)**2 * xlmn + SIN(theta/2.)**2 * xlpl )
          angl_i = -SIN(phi)*( &
               &              COS(theta/2.)**2 * xlmn + SIN(theta/2.)**2 * xlpl )
          ! <2| |1>
       ELSEIF (is1.EQ.is2-2) THEN
          angl_r =  SIN(theta)*xlz +  COS(phi)*(&
               &            - COS(theta/2.)**2 * xlpl + SIN(theta/2.)**2 * xlmn )
          angl_i =  SIN(phi)*( &
               &              COS(theta/2.)**2 * xlpl + SIN(theta/2.)**2 * xlmn )
       ELSE
          angl_r = 0.0
          angl_i = 0.0
       ENDIF
    ENDIF
    !
    anglso = CMPLX(angl_r,angl_i)

    RETURN
  END FUNCTION anglso
END MODULE m_anglso


	SUBROUTINE TI_SUBM  ( idtarr, minuts, jdtarr, iret )
C************************************************************************
C* TI_SUBM								*
C*									*
C* This subroutine subtracts a specified number of minutes from the 	*
C* time in an integer array. The input and output arrays may be the 	*
C* same array.								*
C*									*
C* TI_SUBM  ( IDTARR, MINUTS, JDTARR, IRET )				*
C*									*
C* Input parameters:							*
C*	IDTARR (5)	INTEGER		Time array (YYYY,MM,DD,HH,MM)	*
C*	MINUTS		INTEGER		Number of minutes to subtract	*
C*									*
C* Output parameters:							*
C*	JDTARR (5)	INTEGER		Time array (YYYY,MM,DD,HH,MM)	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -7 = invalid year		*
C*					 -8 = invalid month		*
C*					 -9 = invalid day		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 8/87						*
C* J. Whistler/AWC	 8/95	Based on TI_SUBD			*
C* K. Tyle/GSC		11/95	Fixed leap-year and day/month-change	*
C* M. Linda/GSC		 4/96	Modified syntax so that AIX compiles	*
C* I. Durham/GSC	 9/98	Cleaned up				*
C* S. Jacobs/NCEP	 9/98   Changed minute and hour calculation	*
C* I. Durham/GSC	 9/98	Added correction for negative minutes	*
C* D. Kidwell/NCEP	 4/99	Fixed for Y2K                           *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	INTEGER		idtarr (*), jdtarr (*)
C------------------------------------------------------------------------
	iret = 0
C
C*	Check for negative minutes
C
	IF ( minuts .lt. 0 ) THEN
	   iret = -16
	   RETURN
	END IF
C
C*	Get year, month, day, hour, and minute.
C
	iyear  = idtarr (1)
	imonth = idtarr (2)
	iday   = idtarr (3)
	ihour  = idtarr (4)
	iminut = idtarr (5)
C
C*	Get number of days in month.
C
	CALL TI_DAYM ( iyear, imonth, ndays, ier )
C
C*	Check for valid year.
C
	CALL TI_YY24 ( iyear, iyear, iret )
	IF ( iret .lt. 0 )  RETURN
C
C*	Check for valid month.
C
	IF  ( ( imonth .lt. 1 ) .or. ( imonth .gt. 12 ) )  THEN
	    iret = - 8
	    RETURN
	END IF
C
C*	Check for valid day.
C
	IF  ( ( iday .lt. 1 ) .or. ( iday .gt. ndays ) )  THEN
	    iret  = -9
	    RETURN
	END IF
C
C*	Check for first minute of hour.
C
	jmin = MOD ( minuts, 60 )
	jtmp = minuts / 60
	jhr  = MOD ( jtmp, 24 )
	jday = jtmp / 24
C
	iminut = iminut - jmin
	IF ( iminut .lt. 0 ) THEN
	   iminut = iminut + 60
	   jhr = jhr + 1
	END IF
C
C*	Check for first hour of day.
C
	ihour = ihour - jhr
	IF ( ihour .lt. 0 ) THEN
	   ihour = ihour + 24
	   jday = jday + 1
	END IF
C
	DO k = 1, jday
	   IF ( iday .eq. 1 ) THEN
	      imonth = imonth - 1
	      IF ( imonth .eq. 0 ) THEN
		 iyear = iyear - 1
		 imonth = 12
	      END IF
	      CALL TI_DAYM ( iyear, imonth, ndays, ier )
	      iday = ndays
	   ELSE
	      iday = iday - 1
	   END IF
	END DO
C
C*	Put time in output array.
C
	IF ( idtarr ( 1 ) .lt. 100 ) iyear = MOD ( iyear, 100 )
	jdtarr (1) = iyear
	jdtarr (2) = imonth
	jdtarr (3) = iday
	jdtarr (4) = ihour
	jdtarr (5) = iminut
C*
	RETURN
	END


! 64-bit KISS random number generator
!
! Original version posted to comp.lang.fortran by George Marsaglia:
! http://groups.google.com/group/comp.lang.fortran/msg/1e274596190aaf20
!
! This version was modified by Jason Blevins to use implicit none and
! to portably declare 64-bit/eight-byte integer type.

program test_kiss64
  implicit none
  integer, parameter :: i8b = selected_int_kind(18)  ! eight-byte integer
  integer(i8b) :: i, t

  do i = 1, 100000000
     t = kiss()
  end do

  if (t .eq. 1666297717051644203_i8b) then
     print *, "100 million calls to KISS() OK"
  else
     print *, "Fail"
  end if

contains

  function kiss64()
    integer(i8b), save :: x, y, z, c
    integer(i8b) :: t, k, m, s, kiss
    data x, y, z, c &
         / 1234567890987654321_i8b, &
           362436362436362436_i8b, &
           1066149217761810_i8b, &
           123456123456123456_i8b /
    m(x,k) = ieor(x, ishft(x,k))  ! statement function
    s(x) = ishft(x, -63)          ! statement function
    t = ishft(x, 58) + c
    if (s(x) .eq. s(t)) then
       c = ishft(x, -6) + s(x)
    else
       c = ishft(x, -6) + 1 - s(x + t)
    endif
    x = t + x
    y = m(m(m(y,13_i8b),-17_i8b), 43_i8b)
    z = 6906969069_i8b * z + 1234567
    kiss = x + y + z
  end function kiss64

end program test_kiss64


	SUBROUTINE GCFILLF ( kx, ky, grid, ioffx, ioffy, iskip, nlvl,
     +			     clvl, icolr, linlbl, lintyp, zgrid, iret )
C************************************************************************
C* GCFILLF								*
C* 									*
C* This subroutine draws contours through a grid of data.  The 		*
C* algorithm used is based on a two-dimensional Lagrangian fitting of	*
C* the grid points.  It is the original GEMPAK contouring program.	*
C* The original subroutine, GCONTR, had a different calling sequence.	*
C* 									*
C* GCFILLF ( KX, KY, GRID, IOFFX, IOFFY, ISKIP, NLVL, CLVL, ICOLR,	*
C*           LINLBL, LINTYP, ZGRID, IRET )				*
C*									*
C* Input parameters:							*
C*									*
C*	KX		INTEGER		Number of x grid points 	*
C*	KY		INTEGER		Number of y grid points		*
C*	GRID (KX,KY)	REAL		Grid data array			*
C*	IOFFX		INTEGER		X offset to first point		*
C*	IOFFY		INTEGER		Y offset to first point		*
C*	ISKIP		INTEGER		Skip factor in original grid	*
C*	NLVL		INTEGER		Number of contour levels	*
C*	CLVL   (NLVL)	REAL		Contour level values		*
C*	ICOLR  (NLVL+1)	INTEGER		Contour color numbers		*
C*	LINLBL (NLVL+1)	INTEGER		Contour label types		*
C*	LINTYP (NLVL+1)	INTEGER		Contour fill types		*
C*                                                                      *
C* Work parameters:                                                     *
C*      ZGRID (KX*KY)   REAL            Array for grid points           *
C*									*
C* Output parameters:							*
C*									*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins/NMC	11/91	From GCONTR				*
C* S. Jacobs/NCEP	 1/96	Added CADJST to adjust grid values	*
C* T. Lee/GSC		 9/97	Fixed typo, NOMOMO -> NOMONO		*
C* S. Jacobs/NCEP	 2/00	Eliminate subboxing when CONTUR=1	*
C* T. Lee/SAIC		10/01	Added contour fill types to calling seq.*
C* S. Gilbert/NCEP      03/07   Added work arrays to call sequence      *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE 	'ERROR.PRM'
	INCLUDE		'CONTUR.CMN'
C*
	REAL		grid (*), clvl (*), zgrid (*)
	INTEGER		icolr (*), linlbl (*), lintyp (*)
C*
	LOGICAL		linflg, bad
	REAL		clev (LLCLEV)
	INTEGER		linwid (LLCLEV)
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	Move the contour levels into a local array in order to add a
C*	maximum level.
C
	IF  ( nlvl .lt. LLCLEV )  THEN
	    nlev = nlvl
	  ELSE
	    nlev = LLCLEV - 1
	END IF
	bad = .false.
	DO  i = 1, nlev
	    clev (i) = clvl (i)
	    IF  ( i .gt. 1 )  THEN
		IF  ( clev (i) .le. clev (i-1) )  bad = .true.
	    END IF
	END DO
C
C*	If levels are not in the correct order, set error and return.
C
	IF  ( bad )  THEN
	    iret = NOMONO
	    RETURN
	END IF
C
C*	Build dummy maximum level.
C
	CALL GR_STAT  ( grid, kx, ky, 1, 1, kx, ky, gmin, gmax, gavg,
     +			gdev, ier )
	high = 2 * ABS ( gmax ) + ABS ( gmin )
	IF  ( high .le. clev (nlev) ) high = clev (nlev) + 1
	nlev = nlev + 1
	clev (nlev) = high
C
C*	Read in the box subset factor.  Check that it is valid and set
C*	it in common for the rest of the original contouring code.
C
	IF  ( jbxsub .lt. 2 )  THEN
	    numsub = 2
	  ELSE IF  ( jbxsub .gt. 48 )  THEN
	    numsub = 50
	  ELSE
	    numsub = jbxsub + 2
	END IF
C
C*	Move offsets and skip factor into common.
C
	offx = FLOAT ( ioffx )
	offy = FLOAT ( ioffy )
	skip = FLOAT ( iskip )
C
C*	This program expects the data in the Z array in common.
C
	DO  i = 1, kx * ky
	    zgrid (i) = grid (i)
	END DO
C
C*	Adjust the grid values.
C
	CALL CADJST ( kx, ky, nlev, clev, zgrid, ier )
C
C*	Save grid size as ISIZE, JSIZE.
C
	isize = kx
	jsize = ky
C
C*	Compute distance along each subbox.
C
	fincxy = 1. / FLOAT ( numsub - 1 )
C
C*	Call the driver for the fill contouring.
C
	linflg = .false.
	CALL FFDRIV  ( nlev, clev, icolr, lintyp, linwid, linlbl,
     +		       linflg, zgrid, ier )
C*
	RETURN
	END


!-----------------------------------------------------------------------
!     Module:        boozer_utils
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          07/02/2012
!     Description:   This module contains various routines for working
!                    with Boozer Coordinate data as generated by
!                    the BOOX_XFORM code.
!-----------------------------------------------------------------------
      MODULE boozer_utils
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE read_boozer_mod ! BOOZER Function in LIBSTELL
      USE EZspline_obj
      USE EZspline

!-----------------------------------------------------------------------
!     Module Variables
!
!-----------------------------------------------------------------------
      INTEGER     ::  domain_flag, nfp
      INTEGER     ::  bcs0(2) = (/ 0, 0/)
      INTEGER     ::  bcs1(2) = (/-1,-1/)
      REAL(rprec) ::  pi2, R_target, Z_target, PHI_target
      TYPE(EZspline3_r8) :: R_spl, Z_spl, P_spl, MODB_spl

!-----------------------------------------------------------------------
!     Subroutines
!         load_boozer:     Loads boozer variables
!         get_boozer_s:    Return boozer s,theta,phi coordiante
!-----------------------------------------------------------------------
      CONTAINS

      SUBROUTINE load_boozer(filename,iflag)
      IMPLICIT NONE
      CHARACTER(LEN=*) :: filename
      INTEGER, INTENT(inout) :: iflag
      INTEGER ::  ier, iunit,nvar_in
      INTEGER ::  nu, nv, u, v, mn, dex, ns
      INTEGER, ALLOCATABLE :: im(:), in(:)
      REAL(rprec), ALLOCATABLE :: xu(:), xv(:), rho(:)
      REAL(rprec), ALLOCATABLE :: r_temp(:,:,:), z_temp(:,:,:)
      REAL(rprec), ALLOCATABLE :: p_temp(:,:,:), modb_temp(:,:,:)
      REAL(rprec), ALLOCATABLE :: fmn_temp(:,:)
      pi2 = 8.0 * ATAN(1.0)
      IF (iflag < 0) RETURN
      ! Read the BOOZ_XFORM output
      CALL read_boozer_file(TRIM(filename),iflag)
      IF (iflag .ne. 0) RETURN
      ! Create the radial array
      dex = COUNT(idx_b == 1)
      ns = dex
      ALLOCATE(rho(ns))
      v=1
      DO u = 1, ns_b
         IF (idx_b(u) == 1) THEN
            rho(v) = phi_b(u)
            v = v + 1
         END IF
      END DO
      rho = rho / MAXVAL(rho)
      ! Get the realspace R and Z, p and |B|
      nu = 4* mboz_b + 1
      nv = 4* nboz_b + 1
      ALLOCATE(im(mnboz_b),in(mnboz_b))
      ALLOCATE(xu(nu),xv(nv))
      ALLOCATE(r_temp(nu,nv,ns),z_temp(nu,nv,ns))
      ALLOCATE(p_temp(nu,nv,ns),modb_temp(nu,nv,ns))
      ALLOCATE(fmn_temp(mnboz_b,ns))
      FORALL(u=1:nu) xu(u) = REAL(u-1)/REAL(nu-1)
      FORALL(v=1:nv) xv(v) = REAL(v-1)/REAL(nv-1)
      im =  ixm_b
      in = -ixn_b/nfp_b
      nfp = nfp_b
      r_temp =0; z_temp =0; p_temp=0; modb_temp = 0.0;
      CALL mntouv(1,ns,mnboz_b,nu,nv,xu,xv,rmnc_b,im,in,r_temp,0,1)
      CALL mntouv(1,ns,mnboz_b,nu,nv,xu,xv,zmns_b,im,in,z_temp,1,0)
      CALL mntouv(1,ns,mnboz_b,nu,nv,xu,xv,pmns_b,im,in,p_temp,1,0)
      CALL mntouv(1,ns,mnboz_b,nu,nv,xu,xv,bmnc_b,im,in,modb_temp,0,0)
      IF (lasym_b) THEN
         CALL mntouv(1,ns,mnboz_b,nu,nv,xu,xv,rmns_b,im,in,r_temp,1,0)
         CALL mntouv(1,ns,mnboz_b,nu,nv,xu,xv,zmnc_b,im,in,z_temp,0,0)
         CALL mntouv(1,ns,mnboz_b,nu,nv,xu,xv,pmnc_b,im,in,p_temp,0,0)
         CALL mntouv(1,ns,mnboz_b,nu,nv,xu,xv,bmns_b,im,in,modb_temp,1,0)
      END IF
      ! Constructed 3D Splines
      IF (EZspline_allocated(R_spl)) CALL EZspline_free(R_spl,iflag)
      IF (EZspline_allocated(Z_spl)) CALL EZspline_free(Z_spl,iflag)
      IF (EZspline_allocated(P_spl)) CALL EZspline_free(P_spl,iflag)
      IF (EZspline_allocated(MODB_spl)) CALL EZspline_free(MODB_spl,iflag)
      CALL EZspline_init(R_spl,nu,nv,ns,bcs1,bcs1,bcs0,iflag)
      CALL EZspline_init(Z_spl,nu,nv,ns,bcs1,bcs1,bcs0,iflag)
      CALL EZspline_init(P_spl,nu,nv,ns,bcs1,bcs1,bcs0,iflag)
      CALL EZspline_init(MODB_spl,nu,nv,ns,bcs1,bcs1,bcs0,iflag)
      R_spl%x1 = xu*pi2
      R_spl%x2 = xv*pi2
      R_spl%x3 = rho
      R_spl%isHermite = 1
      Z_spl%x1 = xu*pi2
      Z_spl%x2 = xv*pi2
      Z_spl%x3 = rho
      Z_spl%isHermite = 1
      P_spl%x1 = xu*pi2
      P_spl%x2 = xv*pi2
      P_spl%x3 = rho
      P_spl%isHermite = 1
      MODB_spl%x1 = xu*pi2
      MODB_spl%x2 = xv*pi2
      MODB_spl%x3 = rho
      MODB_spl%isHermite = 1
      CALL EZspline_setup(R_spl,r_temp,iflag)
      CALL EZspline_setup(Z_spl,z_temp,iflag)
      CALL EZspline_setup(P_spl,p_temp,iflag)
      CALL EZspline_setup(MODB_spl,modb_temp,iflag)
      RETURN
      END SUBROUTINE load_boozer

      SUBROUTINE rzfunct_booz(m,n,x,fvec,fjac,ldfjac,iflag)
      IMPLICIT NONE
      INTEGER m,n,ldfjac,iflag, ier
      DOUBLE PRECISION x(n),fvec(m),fjac(ldfjac,n)
      REAL(rprec) :: R_temp, Z_temp, P_temp
      REAL(rprec) :: R_grad(3), Z_grad(3), P_grad(3)
      IF (x(2) < 0.0) x(2) = x(2) + pi2
      x(2) = MOD(x(2),pi2)
      IF (x(3) < 0.0) x(3) = x(3) + pi2
      x(3) = MOD(x(3),pi2)
      IF (x(1) < 0) THEN
         x(1) = -x(1)/2
         x(2) = x(2) +0.5*pi2
         x(2) = MOD(x(2),pi2)
      END IF
      ier = 0
      CALL EZspline_isInDomain(R_spl,x(2),x(3),x(1),ier)
      IF (ier .ne. 0) THEN
         iflag = -1
         domain_flag = -1
      END IF
      IF (iflag == 1) THEN
         CALL EZspline_interp(R_spl,x(2),x(3),x(1),R_temp,iflag)
         CALL EZspline_interp(Z_spl,x(2),x(3),x(1),Z_temp,iflag)
         CALL EZspline_interp(P_spl,x(2),x(3),x(1),P_temp,iflag)
         fvec(1) = (R_temp - R_target)
         fvec(2) = (Z_temp - Z_target)
         fvec(3) = (x(3) + P_temp - PHI_target) ! PHI(cyl) = PHI(booz)+P(s,u,v)
         !PRINT *,R_temp,Z_temp,P_temp
      ELSE IF (iflag == 2) THEN
         CALL EZspline_gradient(R_spl,x(2),x(3),x(1),R_grad,iflag)
         CALL EZspline_gradient(Z_spl,x(2),x(3),x(1),Z_grad,iflag)
         CALL EZspline_gradient(P_spl,x(2),x(3),x(1),P_grad,iflag)
         fjac(1,1) = R_grad(3) !dR/ds
         fjac(1,2) = R_grad(1) !dR/du
         fjac(1,3) = R_grad(2) !dR/dv
         fjac(2,1) = Z_grad(3) !dZ/ds
         fjac(2,2) = Z_grad(1) !dZ/du
         fjac(2,3) = Z_grad(2) !dZ/dv
         fjac(3,1) = P_grad(3) !dP/ds
         fjac(3,2) = P_grad(1) !dP/du
         fjac(3,3) = 1+P_grad(2) !dP/dv
      END IF
      RETURN
      END SUBROUTINE rzfunct_booz

      SUBROUTINE get_booz_s(r_val,phi_val,z_val,s_val,ier,u_val,v_val)
      IMPLICIT NONE
      REAL(rprec), INTENT(in)    ::  r_val
      REAL(rprec), INTENT(in)    ::  phi_val
      REAL(rprec), INTENT(in)    ::  z_val
      REAL(rprec), INTENT(out)   ::  s_val
      REAL(rprec), INTENT(out), OPTIONAL   ::  u_val
      REAL(rprec), INTENT(out), OPTIONAL   ::  v_val
      INTEGER, INTENT(inout)     ::  ier
      INTEGER, PARAMETER :: mfunct=3
      INTEGER, PARAMETER :: nvars=3
      INTEGER, PARAMETER :: ldfjac=3
      INTEGER :: ik, maxfev_local, nfev, info, njev, maxfev, nprint
      INTEGER, DIMENSION(nvars) :: ipvt
      REAL(rprec) :: ftol,xtol,gtol,factor, mode
      REAL(rprec), DIMENSION(nvars)  :: xc_opt, diag, qtf, wa1, wa2, wa3
      REAL(rprec), DIMENSION(mfunct) :: fval,wa4
      REAL(rprec), DIMENSION(ldfjac,nvars) :: fjac
      IF (ier < 0) RETURN
      IF (EZspline_allocated(R_spl) .and. EZspline_allocated(Z_spl) .and. &
          EZspline_allocated(P_spl)) THEN
         R_target = r_val
         Z_target = z_val
         PHI_target = phi_val
         IF (PHI_target < 0) PHI_target = PHI_target + pi2
         PHI_target = MOD(PHI_target,pi2/nfp)*nfp
         xc_opt(1) = 0.5
         xc_opt(2) = 0.0
         xc_opt(3) = PHI_target
         ftol = 1.0E-12
         xtol = 1.0E-12
         gtol = 1.0E-12
         maxfev_local = 5000
         diag(:) = 1.0
         factor = 0.1
         nprint = 0
         domain_flag = 0
         DO ik = 1, 4
            CALL lmder_serial(rzfunct_booz,mfunct,nvars,xc_opt,fval,fjac,ldfjac,ftol,xtol,gtol,&
                    maxfev_local,diag,mode,factor,nprint,info,nfev,njev,ipvt,qtf,&
                    wa1,wa2,wa3,wa4)
            IF (info < 4) EXIT
            xc_opt(2) = xc_opt(2) + 0.05*pi2
            info = 0
            nfev = 0
            njev = 0
         END DO
         ier = info
         IF (info < 4) ier = 0
         IF (domain_flag .ne. 0) THEN
            ier = 9
            s_val = 1.5
            IF (PRESENT(u_val)) u_val = 2*pi2
            IF (PRESENT(v_val)) v_val = 2*pi2
            RETURN
         END IF
         s_val = xc_opt(1)
         IF (PRESENT(u_val)) THEN
            u_val = xc_opt(2)
            u_val = MOD(u_val,pi2)
            DO WHILE (u_val < 0)
               u_val = u_val + pi2
            END DO
         END IF
         IF (PRESENT(v_val)) THEN
            v_val = xc_opt(3)
            v_val = MOD(v_val,pi2)
            DO WHILE (v_val < 0)
               v_val = v_val + pi2
            END DO
         END IF
      ELSE
         ier = -1
      END IF
      RETURN
      END SUBROUTINE get_booz_s

      SUBROUTINE mntouv(k1,k,mnmax,nu,nv,xu,xv,fmn,xm,xn,f,signs,calc_trig)
      IMPLICIT NONE
      INTEGER, INTENT(in) :: k1
      INTEGER, INTENT(in) :: k
      INTEGER, INTENT(in) :: mnmax
      INTEGER, INTENT(in) :: nu
      INTEGER, INTENT(in) :: nv
      REAL(rprec), INTENT(in) :: xu(1:nu)
      REAL(rprec), INTENT(in) :: xv(1:nv)
      REAL(rprec), INTENT(in) :: fmn(1:mnmax,k1:k)
      INTEGER, INTENT(in) :: xm(1:mnmax)
      INTEGER, INTENT(in) :: xn(1:mnmax)
      REAL(rprec), INTENT(inout) :: f(1:nu,1:nv,k1:k)
      INTEGER, INTENT(in) :: signs
      INTEGER, INTENT(in) :: calc_trig
      INTEGER     :: mn, i, ier, ik
      REAL(rprec) :: xm_temp(1:mnmax,1)
      REAL(rprec) :: xn_temp(1:mnmax,1)
      REAL(rprec) :: pi2_l
      REAL(rprec) :: mt(1:mnmax,1:nu)
      REAL(rprec) :: nz(1:mnmax,1:nv)
      REAL(rprec) :: fmn_temp(1:mnmax,1:nu)
      REAL(rprec) :: xu_temp(1,1:nu)
      REAL(rprec) :: xv_temp(1,1:nv)
      REAL(rprec) :: fmn_help(1:mnmax)
      REAL(rprec), ALLOCATABLE, SAVE :: cosmt(:,:)
      REAL(rprec), ALLOCATABLE, SAVE :: sinmt(:,:)
      REAL(rprec), ALLOCATABLE, SAVE :: cosnz(:,:)
      REAL(rprec), ALLOCATABLE, SAVE :: sinnz(:,:)
      pi2_l = 8 * ATAN(1.)
      IF (calc_trig == 1) THEN
         IF (ALLOCATED(cosmt)) DEALLOCATE(cosmt)
         IF (ALLOCATED(sinmt)) DEALLOCATE(sinmt)
         IF (ALLOCATED(cosnz)) DEALLOCATE(cosnz)
         IF (ALLOCATED(sinnz)) DEALLOCATE(sinnz)
         ALLOCATE(cosmt(1:mnmax,1:nu),sinmt(1:mnmax,1:nu),&
                  cosnz(1:mnmax,1:nv),sinnz(1:mnmax,1:nv),STAT=ier)
         FORALL(i=1:mnmax) xm_temp(i,1)=REAL(xm(i))
         FORALL(i=1:mnmax) xn_temp(i,1)=REAL(xn(i))
         FORALL(i=1:nu) xu_temp(1,i)=xu(i)
         FORALL(i=1:nv) xv_temp(1,i)=xv(i)
         mt = MATMUL(xm_temp,xu_temp)
         nz = MATMUL(xn_temp,xv_temp)
         FORALL(mn=1:mnmax,i=1:nu) cosmt(mn,i) = dcos(pi2_l*mt(mn,i))
         FORALL(mn=1:mnmax,i=1:nu) sinmt(mn,i) = dsin(pi2_l*mt(mn,i))
         FORALL(mn=1:mnmax,i=1:nv) cosnz(mn,i) = dcos(pi2_l*nz(mn,i))
         FORALL(mn=1:mnmax,i=1:nv) sinnz(mn,i) = dsin(pi2_l*nz(mn,i))
      END IF
      IF (SIGNS == 0) THEN
         DO ik = k1,k
            FORALL(mn=1:mnmax) fmn_help(mn)=fmn(mn,ik)
            fmn_temp=SPREAD(fmn_help,2,nu)
            f(1:nu,1:nv,ik) = f(1:nu,1:nv,ik)  + MATMUL(TRANSPOSE((fmn_temp*cosmt)),cosnz) &
                                   - MATMUL(TRANSPOSE((fmn_temp*sinmt)),sinnz)
         END DO
      ELSE IF (SIGNS == 1) THEN
         DO ik = k1,k
            FORALL(mn=1:mnmax) fmn_help(mn)=fmn(mn,ik)
            fmn_temp=SPREAD(fmn_help,2,nu)
            f(1:nu,1:nv,ik) = f(1:nu,1:nv,ik) + MATMUL(TRANSPOSE((fmn_temp*sinmt)),cosnz) &
                                  + MATMUL(TRANSPOSE((fmn_temp*cosmt)),sinnz)
         END DO
      END IF
      END SUBROUTINE mntouv

      SUBROUTINE free_booz(ier)
      IMPLICIT NONE
      INTEGER, INTENT(inout) :: ier
      IF (ier < 0) RETURN
      CALL read_boozer_deallocate
      CALL EZspline_free(R_spl,ier)
      CALL EZspline_free(Z_spl,ier)
      CALL EZspline_free(P_spl,ier)
      CALL EZspline_free(MODB_spl,ier)
      RETURN
      END SUBROUTINE free_booz

      END MODULE boozer_utils


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE POLAR
      IMPLICIT   NONE
C
C PURPOSE: TRANSFORM IMAGE EXPRESSED IN CARTESIAN COORDINATES TO AN
C          IMAGE IN POLAR COORDINATES.
C
      INCLUDE 'COMMON.FOR'
C
C Calls  11: IMDISP , WFRAME , RFRAME , IMSIZE , OUTFIL
C            GETVAL , GETHDR , OPNFIL , OPNNEW
C Called by: BSL
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C LOCAL VARIABLES:
C
      REAL         DTHETA,RADIUS,THETA,RMIN,VALUE(10),X,Y,PI
      INTEGER      ICENTX,ICENTY,IX,IY,INDX1,INDX2,MRAST,MPIX,MRAST4
      INTEGER      IRC,IFRAME,IHFMAX,IFRMAX,NPIX,NRAST,NFRAME,IMEM
      INTEGER      KPIC,ISPEC,LSPEC,MEM,IFFR,ILFR,INCR,IFINC,NVAL,I,J,K
      INTEGER      ITEMP,L,M
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 HFNAM,OFNAM
C
C IRC    : Return code
C IFRAME : Total nos. of frames
C IFRMAX : Nos. of frames in sequence
C IHFMAX : Nos. of header file in sequence
C ISPEC  : First header file of sequence
C LSPEC  : Last header file in sequence
C MEM    : Positional or calibration data indicator
C IFFR   : First frame in sequence
C ILFR   : Last frame in sequence
C INCR   : Header file increment
C IFINC  : Frame increment
C HFNAM  : Header filename
C OFNAM  : Output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C IMEM   : Output memory dataset
C NPIX   : Nos. of pixels in image
C NRAST  : Nos. of rasters in image
C NFRAME : Nos. of frames in dataset
C KPIC   : Current image nos.
C NVAL   : Nos. of values entered at terminal
C DTHETA : Increment of theta
C RADIUS : Polar radius
C THETA  : Polar angle
C RMIN   : Minimum value of theta
C ICENTX : Centre x coordinate
C ICENTY : Centre y coordinate
C IX     : Integerised x coordinate for given r,theta
C IY     : Integerised y coordinate for given r,theta
C INDX1  : Offset to buffer
C INDX2  : Offset to buffer

      DATA RMIN/0.00001/ , IMEM/1/
C
C-----------------------------------------------------------------------
10    KPIC=0
C
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,IFFR,
     &             ILFR,IFINC,IHFMAX,IFRMAX,NPIX,NRAST,IRC)
      IF (IRC.NE.0) GOTO 999
      IFRAME=4
C
C========FIND X,Y COORDINATES FOR CENTRE OF POLAR COORDINATES
C
      ICENTX=NPIX/2
      ICENTY=NRAST/2
20    WRITE (IPRINT,1000) ICENTX,ICENTY
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 10
      IF (IRC.EQ.2) GOTO 20
      IF (NVAL.GT.0) ICENTX=VALUE(1)
      IF (NVAL.GT.1) ICENTY=VALUE(2)
C
C========FIND MAXIMUM RADIUS OBTAINABLE FROM GIVEN CENTRE
C
      PI=ACOS(-1.0)
      MPIX=MIN (NPIX-ICENTX,ICENTX,NRAST-ICENTY,ICENTY)
      MRAST=INT(2.0*PI*REAL(MPIX))
      DTHETA=2.0*PI/REAL(MRAST)
      MRAST4=MRAST/4
C
      DO 70 I=1,IHFMAX
         CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NPIX,NRAST,
     &                NFRAME,IRC)
         IF (IRC.EQ.0) THEN
C
            ISPEC=ISPEC+INCR
            DO 60 J=1,IFRMAX
               CALL RFRAME (JUNIT,IFFR,NPIX,NRAST,SP1,IRC)
               IF (IRC.NE.0) GOTO 80
               IFFR=IFFR+IFINC
               KPIC=KPIC+1
C
C========CALCULATE POLAR IMAGE
C
               DO 50 K=1,4
                  INDX2=1
                  DO 40 L=1,MRAST4
                     THETA=DTHETA*REAL(L)
                     DO 30 M=1,MPIX
                        RADIUS=REAL(M)
                        X=RADIUS*COS(THETA)
                        Y=RADIUS*SIN(THETA)
                        IX=INT(X-RMIN)+1
                        IY=INT(Y-RMIN)+1
C
C========CORRECT EACH QUADRANT FOR CENTRE OFFSET
C
                        IF (K.EQ.1) THEN
                           IX=IX+ICENTX
                           IY=IY+ICENTY
                        ELSEIF (K.EQ.2) THEN
                           ITEMP=IX
                           IX=-IY+ICENTX+1
                           IY=ITEMP+ICENTY
                        ELSEIF (K.LE.3) THEN
                           IX=-IX+ICENTX+1
                           IY=-IY+ICENTY+1
                        ELSE
                           ITEMP=-IX
                           IX=IY+ICENTX
                           IY=ITEMP+ICENTY+1
                        ENDIF
                        INDX1=NPIX*(IY-1)+IX
                        SP2(INDX2)=SP1(INDX1)*2.0*PI*(M+0.5)/NPIX
                        INDX2=INDX2+1
30                   CONTINUE
40                CONTINUE
C
                  IF (K.EQ.1) THEN
                     IF (KPIC.EQ.1) CALL IMDISP(ITERM,IPRINT,SP2,MPIX,
     &                                          MRAST4)
                     CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
                     IF (IRC.NE.0) GOTO 80
                     CALL OPNNEW (KUNIT,MPIX,MRAST4,IFRAME,OFNAM,IMEM,
     &                            HEAD1,HEAD2,IRC)
                     IF (IRC.NE.0) GOTO 80
                  ENDIF
                  CALL WFRAME (KUNIT,K,MPIX,MRAST4,SP2,IRC)
                  IF (IRC.NE.0) GOTO 80
50             CONTINUE
               CALL FCLOSE (KUNIT)
60          CONTINUE
            CALL FCLOSE (JUNIT)
         ENDIF
70    CONTINUE
80    CALL FCLOSE (KUNIT)
      CALL FCLOSE (JUNIT)
      GOTO 10
999   RETURN
C
1000  FORMAT (' Enter x,y coordinate for polar image centre',
     &        ' [',I4,',',I4,'] : ',$)
      END


! Implementantion of the mark-1 perceptron
! Follows the optimization algorithm presented by Minsky and Papert
! In the algorithm, we:
!   1. Initialize the weights randomly
!   2. Pick a random input
!   3. If classified correctly, do nothing
!   4. If classified incorrectly:
!       4a. If false positive, decrease all weights by x
!       4b. If false negative, increase all weights by x
!   5. If no weights were classified incorrectly, we're done
!   If linearly separable, should converge to the right weights

      subroutine getConsoleInput(x)
        ! Gets an input vector from the console
        integer, dimension(1:784), intent(inout) :: x
        integer :: i
        read(5,*) x(:)
      end subroutine getConsoleInput

      subroutine monochrome(x)
        ! Takes a greyscale input and converts to monochrome
        integer, dimension(1:784), intent(inout) :: x
        integer :: i
        do i = 1, 784, 1
            if (x(i) < 128) then
                x(i) = 0
            else
                x(i) = 1
            endif
        end do
      end subroutine monochrome

      function heaviside(x)
        ! Heaviside step function
        ! Returns 1 if x >= 0, and 0 if x < 0
        real, intent(in) :: x
        integer :: heaviside
        if (x >= 0) then
            heaviside = 1
        else
            heaviside = 0
        endif
      end function heaviside

      function neuron(input, weights, bias) result(predicted)
          ! A neuron function; multiplies all inputs by weights, sums them,
          ! then adds a bias. Returns true or false based on activation
          ! function.
          integer, dimension(1:784), intent(in) :: input
          real, dimension(1:784), intent(in) :: weights
          real, intent(in) :: bias
          real :: potential
          integer :: predicted
          integer :: heaviside
          ! Multiply all inputs by weights
          potential =  dot_product(input, weights) + bias
          predicted = heaviside(potential)
      end function neuron

      program perceptron
        ! Take in a 28 * 28 image = 784 pixels
        implicit none
        integer, dimension(1:784) :: input ! Input vector
        integer, dimension(0:9) :: output ! Output vector
        real, dimension(0:9, 1:784) :: weights ! Weights vector
        real, dimension(0:9) :: bias ! Bias vector
        integer :: truth  ! The true value of the number
        integer :: prediction ! Predicted value of the neuron
        integer :: neuron ! Neuron function output
        integer :: i,j,k    ! Loop counters
        integer :: truePos, falsePos ! True and false positive counters

        ! Initialize random seed
        ! This segment of code mostly based on a Linux forum post
        integer :: values(1:8), nonce
        integer, dimension(:), allocatable :: seed
        write(*,*) "Initializing random seed..."
        call date_and_time(VALUES = values)
        call random_seed(size = nonce)
        allocate(seed(1:nonce))
        seed(:) = values(8)
        call random_seed(put=seed)

        ! Initialize bias
        write(*,*) "Starting bias at 0..."
        bias = 0

        ! Randomize the weights
        write(*,*) "Assigning random weights..."
        do i = 0, 9, 1
            do j = 1, 784, 1
                call random_number(weights(i,j))
            end do
        end do

        ! Open the training set
        write(*,*) "Acquiring training data..."
        open(UNIT = 10, FILE = "training.csv", FORM = "FORMATTED", STATUS = "OLD", ACTION = "READ")
        write(*,*) "Training..."
        do k = 1, 5, 1 ! Number of training loops
            write(*,*) "Iteration number ", k
            write(*,*) "Training weights..."
            do i = 1, 60000, 1 !MNIST dataset has 60,000 numbers in the training set
                read(10,*) truth, input(:)
                call monochrome(input)
                ! Update Neurons
                do j = 0, 9, 1
                    prediction = neuron(input, weights(j,:), bias(j))
                    if (prediction == 1) then
                        if (j == truth) then
                            ! True positive
                            ! Do nothing; we predicted correctly
                            continue
                        else
                            ! False positive
                            ! Subtract x from our weights
                            weights(j,1:784) = weights(j,1:784) - input(1:784)
                        endif
                    else
                        if (j /= truth) then
                            ! True negative
                            ! Do nothing; we predicted correctly
                            continue
                        else
                            ! False negative
                            ! Add x to all of our weights
                            weights(j, 1:784) = weights(j, 1:784) + input(1:784)
                        endif
                    endif
                end do
            end do
            write(*,*) "Training bias..."
            rewind(10)
            do i=1, 60000, 1
                read(10,*) truth, input(:)
                call monochrome(input)
                ! Update neurons
                do j = 0, 9, 1
                    prediction = neuron(input, weights(j, :), bias(j))
                    if (prediction == 1) then
                        if (j == truth) then
                            ! True positive
                            continue
                        else
                            ! False positive
                            bias(j) = bias(j) - 1
                        endif
                    else
                        if (j /= truth) then
                            ! True negative
                            continue
                        else
                            ! False negative
                            bias(j) = bias(j) + 1
                        endif
                    endif
                end do
            end do
            rewind(10)
        end do
        close(10)

        ! Open the test set
        write(*,*) "Acquiring test data..."
        open(UNIT = 11, FILE = "test.csv", FORM = "FORMATTED", STATUS = "OLD", ACTION = "READ")
        truePos = 0 ! True positives counter
        falsePos = 0 ! False positive counter
        do i = 1, 10000, 1 !MNIST dataset has 10,000 numbers in the test set
            read(11, *) truth, input(:)
            call monochrome(input)
            !write(*,*) "Truth: ", truth
            do j = 0, 9, 1
                prediction = neuron(input, weights(j, :), bias(j))
                if (prediction == 1) then
                    !write(*,*) "Prediction: ", j
                    if (j == truth) then
                        truePos = truePos + 1
                    else
                        falsePos = falsePos + 1
                    endif
                endif
            end do
        end do
        close(11)
        write(*,*) "Correct positives: ", truePos
        write(*,*) "False positives: ", falsePos

        ! Ready for input
20      write(*,*) "Ready for input. Enter an input vector."
        call getConsoleInput(input)
        do i = 0, 9, 1
            if (neuron(input, weights(i, :), bias(i)) == 1) then
                write(*,*) "I see ", i
            endif
        end do

        ! No halting condition; just ctrl+c the process away...
        goto 20

      end program perceptron


module mod_cond_orth_band
  use mod_prec
  use mod_error_id
  use mod_rotation
  use mod_orth_band_types
  use mod_band_types
  use mod_solve
  use mod_products
  use mod_utility
  use mod_submatrix
  use mod_convert

  implicit none

  private

  public :: ub_min_sv, d_ub_min_sv, z_ub_min_sv, &
       ub_max_sv, d_ub_max_sv, z_ub_max_sv

  interface ub_min_sv
     module procedure d_ub_min_sv, z_ub_min_sv
  end interface ub_min_sv

  interface ub_max_sv
     module procedure d_ub_max_sv, z_ub_max_sv
  end interface ub_max_sv

  integer(kind=int32), parameter :: default_maxit=20
  real(kind=dp), parameter :: default_tol=4*eps, default_tolres=4*eps

contains

  ! minimum singular values/vectors for upper triangular stored as a
  ! UB decomp.
  ! errors:
  ! 1: n<1
  ! 2: size error
  ! 3: ub is not upper triangular
  ! 4: numerically singular; no null vector computed
  ! 5: failed to converge
  real(kind=dp) function d_ub_min_sv(ub,un,vn,res,tolres0, &
       maxit0,error) result(sigmau)
    type(d_ub), intent(in) :: ub
    real(kind=dp), dimension(:), intent(out) :: un,vn,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit, p, q
    real(kind=dp) :: tolres, sigmav, maxub
    real(kind=dp), dimension(size(un)) :: tmpv
    real(kind=dp), dimension(size(un),1) :: tmpc
    real(kind=dp), dimension(1,size(un)) :: tmpr
    type(routine_info), parameter :: info=info_d_ub_min_sv
    type(d_bv), allocatable :: bv, bvt
    type(d_ub), allocatable :: ubl

    sigmau=0.0_dp
    n=get_n(ub)
    if (failure(error)) return
    call push_id(info, error)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(un) .or. n /= size(vn) .or. n /= size(res)) then
       call set_error(2, info, error); return
    else if (ub%lbw /=0) then
       call set_error(3, info, error); return
    end if

    maxub=maxabs(ub%bc(1:ub%lbw+ub%ubw+1,:))
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxub*default_tolres,tolres0)

    un=0.0_dp
    vn=0.0_dp
    if (maxub==0.0_dp) then
       un(1)=1.0_dp; vn(1)=1.0_dp
       sigmau=0.0_dp
       res=0.0_dp
       call pop_id(error)
       return
    else
       ! treat very small diagonal elements as hard zeros.
       p=first_zero(ub%bc(ub%ubw+1,:), maxub*eps*eps)
       q=reverse_first_zero(ub%bc(ub%ubw+1,:), maxub*eps*eps)
       bv=bv_of(ub,error)
       if (p<=n .or. q >= 1) then
          vn(p)=1.0_dp
          un(q)=1.0_dp
          if (p > 1) then
             ubl=leading(ub,p-1)
             call ub_to_columns(p,p,ub,tmpc,error)
             tmpv(1:p-1)=-tmpc(1:p-1,1)
             call back_solve_ub(ubl,vn(1:p-1),tmpv(1:p-1),error)
          end if
          if (q < n) then
             bvt=trailing(bv,n-q)
             call bv_to_rows(q,q,bv,tmpr,error)
             tmpv(q+1:n)=-tmpr(1,q+1:n)
             call forward_solve_bv(un(q+1:n),bvt,tmpv(q+1:n))
          end if
          if (failure(error)) return
          if (.not. is_number(un(q+1:n)) .or. .not. is_number(vn(1:p-1))) then
             call set_error(4,info,error)
             return
          end if
          ! un=conjg(un)
          un=un/norm2(un); vn=vn/norm2(vn)
          sigmau=0.0_dp
          ! Residual is R*vn-sigma*un or just R*vn
          res=0.0_dp
          ubl=leading(ub,p)
          tmpc(1:p,1)=vn(1:p)
          call ub_times_general(ubl,reshape(vn(1:p),[p,1]),tmpc(1:p,:),error)
          res(1:p)=tmpc(1:p,1)
          if (failure(error)) return
          call pop_id(error); return
       else
          ! start with a random vector
          call random_matrix_to(un)
          un=un/norm2(un)
          k=1
          do while (k <= maxit)
             ! Update v
             tmpv=un
             call back_solve_ub(ub,vn,tmpv,error)
             if (failure(error)) return
             if (.not. is_number(vn)) then
                call set_error(4,info,error)
                return
             end if
             sigmav=1/norm2(vn)
             vn=sigmav*vn
             ! Update un
             res=un
             tmpv=vn
             call forward_solve_bv(un,bv,tmpv,error)
             if (failure(error)) return
             if (.not. is_number(un)) then
                call set_error(4,info,error)
                return
             end if
             ! un=conjg(un) and conjg(vn) above
             sigmau=1/norm2(un)
             un=sigmau*un
             res=res*sigmav - un*sigmau
             if (norm2(res) < tolres) then
                call general_times_ub(reshape(un,[1,n]),ub,tmpr)
                sigmau=normf(tmpr)
                call pop_id(error)
                return
             end if
             k=k+1
          end do
          if (tolres==0.0_dp) then
             ! maxits is OK if tolerance is zero.
             call general_times_ub(reshape(un,[1,n]),ub,tmpr)
             sigmau=normf(tmpr)
             call pop_id(error)
          else
             call set_error(5, info, error); return
          end if
       end if
    end if
  end function d_ub_min_sv

  ! minimum singular values/vectors for upper triangular stored as a
  ! UB decomp.
  real(kind=dp) function z_ub_min_sv(ub,un,vn,res,tolres0, &
       maxit0,error) result(sigmau)
    type(z_ub), intent(in) :: ub
    complex(kind=dp), dimension(:), intent(out) :: un,vn,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit, p, q
    real(kind=dp) :: tolres, sigmav, maxub
    complex(kind=dp), dimension(size(un)) :: tmpv
    complex(kind=dp), dimension(size(un),1) :: tmpc
    complex(kind=dp), dimension(1,size(un)) :: tmpr
    type(routine_info), parameter :: info=info_z_ub_min_sv
    type(z_bv), allocatable :: bv, bvt
    type(z_ub), allocatable :: ubl

    sigmau=0.0_dp
    n=get_n(ub)
    if (failure(error)) return
    call push_id(info, error)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(un) .or. n /= size(vn) .or. n /= size(res)) then
       call set_error(2, info, error); return
    else if (ub%lbw /=0) then
       call set_error(3, info, error); return
    end if

    maxub=maxabs(ub%bc(1:ub%lbw+ub%ubw+1,:))
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxub*default_tolres,tolres0)

    un=(0.0_dp,0.0_dp)
    vn=(0.0_dp,0.0_dp)
    if (maxub==0.0_dp) then
       un(1)=(1.0_dp,0.0_dp); vn(1)=(1.0_dp,0.0_dp)
       sigmau=0.0_dp
       res=(0.0_dp,0.0_dp)
       call pop_id(error)
       return
    else
       ! treat very small diagonal elements as hard zeros.
       p=first_zero(ub%bc(ub%ubw+1,:), maxub*eps*eps)
       q=reverse_first_zero(ub%bc(ub%ubw+1,:), maxub*eps*eps)
       bv=bv_of(ub,error)
       if (p<=n .or. q >= 1) then
          vn(p)=(1.0_dp,0.0_dp)
          un(q)=(1.0_dp,0.0_dp)
          if (p > 1) then
             ubl=leading(ub,p-1)
             call ub_to_columns(p,p,ub,tmpc,error)
             tmpv(1:p-1)=-tmpc(1:p-1,1)
             call back_solve_ub(ubl,vn(1:p-1),tmpv(1:p-1),error)
          end if
          if (q < n) then
             bvt=trailing(bv,n-q)
             call bv_to_rows(q,q,bv,tmpr,error)
             tmpv(q+1:n)=-tmpr(1,q+1:n)
             call forward_solve_bv(un(q+1:n),bvt,tmpv(q+1:n))
          end if
          if (failure(error)) return
          if (.not. is_number(un(q+1:n)) .or. .not. is_number(vn(1:p-1))) then
             call set_error(4,info,error)
             return
          end if
          un=conjg(un)
          un=un/norm2(un); vn=vn/norm2(vn)
          sigmau=0.0_dp
          ! Residual is R*vn-sigma*un or just R*vn
          res=(0.0_dp,0.0_dp)
          ubl=leading(ub,p)
          tmpc(1:p,1)=vn(1:p)
          call ub_times_general(ubl,reshape(vn(1:p),[p,1]),tmpc(1:p,:),error)
          res(1:p)=tmpc(1:p,1)
          if (failure(error)) return
          call pop_id(error); return
       else
          ! start with a random vector
          call random_matrix_to(un)
          un=un/norm2(un)
          k=1
          do while (k <= maxit)
             ! Update v
             tmpv=un
             call back_solve_ub(ub,vn,tmpv,error)
             if (failure(error)) return
             if (.not. is_number(vn)) then
                call set_error(4,info,error)
                return
             end if
             sigmav=1/norm2(vn)
             vn=sigmav*vn
             ! Update un
             res=un
             tmpv=conjg(vn)
             call forward_solve_bv(un,bv,tmpv,error)
             if (failure(error)) return
             if (.not. is_number(un)) then
                call set_error(4,info,error)
                return
             end if
             un=conjg(un)
             sigmau=1/norm2(un)
             un=sigmau*un
             res=res*sigmav - un*sigmau
             if (norm2(res) < tolres) then
                call general_times_ub(conjg(reshape(un,[1,n])),ub,tmpr)
                sigmau=normf(tmpr)
                call pop_id(error)
                return
             end if
             k=k+1
          end do
          if (tolres==0.0_dp) then
             ! maxits is OK if tolerance is zero.
             call general_times_ub(conjg(reshape(un,[1,n])),ub,tmpr)
             sigmau=normf(tmpr)
             call pop_id(error)
          else
             call set_error(5, info, error); return
          end if
       end if
    end if
  end function z_ub_min_sv

  ! maximum singular values/vectors for upper triangular stored as a
  ! UB decomp.
  ! errors:
  ! 1: n<1
  ! 2: size error
  ! 3: failed to converge
  real(kind=dp) function d_ub_max_sv(ub,u1,v1,res,tolres0, &
       maxit0,error) result(sigmau)
    type(d_ub), intent(in) :: ub
    real(kind=dp), dimension(:), intent(out) :: u1,v1,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit
    real(kind=dp) :: tolres, sigmav, maxub, sigmau0
    real(kind=dp), dimension(size(u1),1) :: tmpc
    real(kind=dp), dimension(1,size(u1)) :: tmpr
    type(routine_info), parameter :: info=info_d_ub_max_sv

    sigmau=0.0_dp
    n=get_n(ub)
    if (failure(error)) return
    call push_id(info, error)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(u1) .or. n /= size(v1) .or. n /= size(res)) then
       call set_error(2, info, error); return
    end if

    maxub=maxabs(ub%bc(1:ub%lbw+ub%ubw+1,:))
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxub*default_tolres,tolres0)

    u1=0.0_dp
    v1=0.0_dp
    if (maxub==0.0_dp) then
       u1(1)=1.0_dp; v1(1)=1.0_dp
       sigmau=0.0_dp
       res=0.0_dp
       call pop_id(error)
       return
    else
       ! start with a random vector
       call random_matrix_to(v1)
       v1=v1/norm2(v1)
       k=1
       do while (k <= maxit)
          ! Update u1
          res=u1; sigmau0=sigmau
          call ub_times_general(ub,reshape(v1,[n,1]),tmpc,error)
          u1=tmpc(:,1)
          if (failure(error)) return
          sigmav=norm2(u1)
          u1=u1/sigmav
          ! update v1
          call general_times_ub(reshape(u1,[1,n]),ub,tmpr)
          v1=tmpr(1,:)
          sigmau=norm2(v1)
          v1=v1/sigmau
          res = u1*sigmav-res*sigmau0
          if (norm2(res) < tolres) then
             call pop_id(error)
             return
          end if
          k=k+1
       end do
       if (tolres==0.0_dp) then
          ! maxits is OK if tolerance is zero.
          call pop_id(error)
       else
          call set_error(3, info, error); return
       end if
    end if
  end function d_ub_max_sv

  ! maximum singular values/vectors for upper triangular stored as a
  ! UB decomp.
  ! errors:
  ! 1: n<1
  ! 2: size error
  ! 3: failed to converge
  real(kind=dp) function z_ub_max_sv(ub,u1,v1,res,tolres0, &
       maxit0,error) result(sigmau)
    type(z_ub), intent(in) :: ub
    complex(kind=dp), dimension(:), intent(out) :: u1,v1,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit
    real(kind=dp) :: tolres, sigmav, maxub, sigmau0
    complex(kind=dp), dimension(size(u1),1) :: tmpc
    complex(kind=dp), dimension(1,size(u1)) :: tmpr
    type(routine_info), parameter :: info=info_z_ub_max_sv

    sigmau=0.0_dp
    n=get_n(ub)
    if (failure(error)) return
    call push_id(info, error)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(u1) .or. n /= size(v1) .or. n /= size(res)) then
       call set_error(2, info, error); return
    end if

    maxub=maxabs(ub%bc(1:ub%lbw+ub%ubw+1,:))
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxub*default_tolres,tolres0)

    u1=(0.0_dp,0.0_dp)
    v1=(0.0_dp,0.0_dp)
    if (maxub==0.0_dp) then
       u1(1)=1.0_dp; v1(1)=1.0_dp
       sigmau=0.0_dp
       res=(0.0_dp,0.0_dp)
       call pop_id(error)
       return
    else
       ! start with a random vector
       call random_matrix_to(v1)
       v1=v1/norm2(v1)
       k=1
       do while (k <= maxit)
          ! Update u1
          res=u1; sigmau0=sigmau
          call ub_times_general(ub,reshape(v1,[n,1]),tmpc,error)
          u1=tmpc(:,1)
          if (failure(error)) return
          sigmav=norm2(u1)
          u1=u1/sigmav
          ! update v1
          call general_times_ub(reshape(conjg(u1),[1,n]),ub,tmpr)
          v1=conjg(tmpr(1,:))
          sigmau=norm2(v1)
          v1=v1/sigmau
          res = u1*sigmav-res*sigmau0
          if (norm2(res) < tolres) then
             call pop_id(error)
             return
          end if
          k=k+1
       end do
       if (tolres==0.0_dp) then
          ! maxits is OK if tolerance is zero.
          call pop_id(error)
       else
          call set_error(3, info, error); return
       end if
    end if
  end function z_ub_max_sv

end module mod_cond_orth_band


! $UWHPSC/codes/fortran/sub2.f90

program sub2
    implicit none
    real(kind=8), dimension(3) :: y,z
    integer n

    y = (/2., 3., 4./)
    n = size(y)
    call fsub(y,n,z)
    print *, "z = ",z
end program sub2

subroutine fsub(x,n,f)
  ! compute f(x) = x**2 for all elements of the array x
  ! of length n.
  implicit none
  integer, intent(in) :: n
  real(kind=8), dimension(n), intent(in) :: x
  real(kind=8), dimension(n), intent(out) :: f
  f = x**2
end subroutine fsub


      SUBROUTINE blk3d(a, bm1, bp1, srces, mblk, nblocks)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE stel_kinds
      USE safe_open_mod
      IMPLICIT NONE
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      INTEGER, PARAMETER :: bytes_per_rprec = 8
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: nblocks, mblk
      REAL(rprec), DIMENSION(mblk,mblk,nblocks), INTENT(in) ::
     1                       a, bp1, bm1
      REAL(rprec), DIMENSION(mblk,nblocks), INTENT(inout) :: srces
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
!      INTEGER :: ibuph, incnow, irecl, incbu, iunit=102, ndisk
      INTEGER :: k, k1, ier
      INTEGER, ALLOCATABLE, DIMENSION(:) :: ipiv
      REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: ainv
      REAL(rprec), DIMENSION(:,:,:), ALLOCATABLE :: ql
C-----------------------------------------------
C   E x t e r n a l  S u b r o u t i n e s
C-----------------------------------------------
      EXTERNAL la_getrf, la_getrs
C-----------------------------------------------
c  modified (June, 2003, ORNL):         S. P. Hirshman
c-----------------------------------------------------------------------
c
c  this subroutine solves a block-tridiagonal system of equations.
c
c-----------------------------------------------------------------------
c  INPUT
c  mblk                : block size
c  nblocks             : number of blocks
c  a                   : diagonal block
c  bm1, bp1            : lower, upper block (see equation below)
c  srces(mblk,nblocks) : right-hand size source
c
c  LOCAL VARIABLES
c  iunit               : unit number for block-tridiagonal solution disk file.
c
c  solutions are indexed in m-n fourier-space, legendre-space. the tri-diagonal
c  equation is:
c
c           bm1 * f(l-1) + a * f(l) + bp1 * f(l+1) = source(l)
c
c     GENERAL SOLUTION SCHEME APPLIED TO EACH BLOCK ROW (INDEX L)
c
c     1. Start from row N and solve for x(N) in terms of x(N-1):
c
c        x(N) = -q(N)*x(N-1) + r(N)
c
c        q(N) =  a(N)[-1] * bm1;    r(N) = a(N)[-1] * s(N)
c
c        where a(N)[-1] is the inverse of a(N)
c
c     2. Substitute for lth row to get recursion equation fo q(l) and r(l):
c
c        x(l) = -q(l)*x(l-1) + r(l), in general, where:
c
c        q(l) = (a(l) - bp1(l)*q(l+1))[-1] * bm1(l)
c
c        r(l) = (a(l) - bp1(l)*q(l+1))[-1] * (s(l) - bp1(l)*r(l+1))
c
c     3. At row l = 1, bm1(1) = 0 and get an equation for x(1) corresponding to q(1) = 0:
c
c        x(1) = r(1)
c
c     4. Finally, can back-solve for x(N) in terms of x(N-1) from eqn.(1) above
c
c
c     NUMERICAL IMPLEMENTATION (USING LAPACK, la_... ROUTINES)
c
c     1. CALL la_getrf:   Perform LU factorization of diagonal block (A)
c     2. CALL la_getrs:   With multiple (mblk) right-hand sides, to do block inversion
c                         operation, A X = B  (store result in X; here B is a matrix)
c     3. CALL la_getrs:   With single right hand side (source) to solve A x = b (b a vector)
c
!      ndisk = mblk

      ALLOCATE (ql(mblk,mblk, nblocks), ainv(mblk,mblk), ipiv(mblk),
     1          stat=ier)
      IF (ier .ne. 0) STOP 'Allocation error in blk3d'

c  create disk file for doing direct access i/o.

!      incnow = ndisk
!      irecl  = bytes_per_rprec*incnow
!      incbu = 1 + (ndisk - 1)/incnow
!      ibuph = 0

!      iunit = 10
!      CALL safe_open(iunit, ier, 'NULL', 'scratch', 'unformatted',
!     1     irecl, 'DIRECT')
!      IF (ier .ne. 0) STOP 'Error opening scratch file in blk3d'

      ainv = a(:,:,nblocks)

c  main loop. load and process (backwards) block-rows nblocks to 1.

      BLOCKS: DO k = nblocks, 1, -1
!
!     Compute (and save) ql(nblocks) = a(nblocks)[-1] * ql, and source terms A-1 * srces [A-1 == inv(A)]
!
         CALL la_getrf (mblk, mblk, ainv, mblk, ipiv, ier)
         IF (ier .ne. 0) GOTO 200

         IF (k .gt. 1) THEN
            ql(:,:,k) = bm1(:,:,k)
            CALL la_getrs('n', mblk, mblk, ainv,
     1                    mblk, ipiv, ql(1,1,k), mblk, ier)
            CALL la_getrs('n', mblk, 1,    ainv,
     1                    mblk,ipiv,srces(1,k),mblk,ier)

!            CALL wrdisk(iunit, ql, ndisk, incnow, ibuph, incbu, ier)
!            IF (ier .ne. 0) GOTO 302
         ELSE
            CALL la_getrs('n', mblk, 1,   ainv,
     1                    mblk,ipiv,srces(1,k),mblk,ier)
         END IF

         k1 = k - 1
         IF (k1 .eq. 0) EXIT

!
!      Update effective diagonal "a" matrix and source terms and store ql 2 l-steps back
!
         ainv  = a(:,:,k1) - MATMUL(bp1(:,:,k1), ql(:,:,k))
         srces(:,k1) = srces(:,k1) - MATMUL(bp1(:,:,k1),srces(:,k))

      END DO BLOCKS

c  backward solution sweep for block-rows k = 2 to nblocks
c  read blocks ql from disk.

      DO k = 2, nblocks
!         CALL rddisk (iunit, ql, ndisk, incnow, ibuph, ier)
!         IF (ier .ne. 0) GOTO 303
!         ibuph = ibuph - incbu
         srces(:,k) = srces(:,k) - MATMUL(ql(:,:,k),srces(:,k-1))
      END DO

      GOTO 400

c  error returns. ------------------------------------------------------

  200 CONTINUE
      WRITE (6, '(a,i4)') ' Error factoring matrix in blk3d: block = '
     1                     , k,' error id = ', ier
      GOTO 400
  301 CONTINUE
!      WRITE (6, '(a,i8)') ' BLK3D:   error in opening file:  ',
!     1   'RECL = ', irecl
  302 CONTINUE
      WRITE (6, '(a)') ' BLK3D:   error in I/O routine WRDISK'
  303 CONTINUE
      WRITE (6, '(a)') ' BLK3D:   error in I/O routine RDDISK'
      ier = -2
  305 CONTINUE
      WRITE (6, '(2/a,i4,2/)') ' BLK3D:   error detected:   ier =',
     1   ier
      STOP

c  destroy disk file and return. ---------------------------------------

  400 CONTINUE

!      CLOSE (iunit)

      DEALLOCATE (ainv, ql, ipiv)

      END SUBROUTINE blk3d


! Routine for generating sons through crossover technique.
! Igor Lopes, February 2015
SUBROUTINE REPRODUCTION(POPO,POP,VFITO,VFIT,NSURV,NPOP,NTBIT)
    IMPLICIT NONE
    ! Parameters
    REAL(8) R0 /0.0D0/
    REAL(8) R2 /2.0D0/
    ! Argument
    INTEGER :: NSURV, NPOP, NTBIT
    REAL(8),DIMENSION(NPOP) :: VFIT, VFITO
    INTEGER,DIMENSION(NPOP,NTBIT)   :: POPO, POP
    ! Locals
    INTEGER     :: IPOP, JPOP, IPOS, NPOS
    REAL(8),DIMENSION(NPOP) :: VAFIT
    REAL(8)     :: SUM, RANDN
    INTEGER,DIMENSION(2,NTBIT) :: PAR
    ! Initialize
    VAFIT=R0
    SUM=R0
    IPOS=NSURV
    ! Algorithm
    ! Parents
    VAFIT(1)=VFITO(1)
    SUM=VFITO(1)
    DO IPOP=2,NPOP
        VAFIT(IPOP)=VAFIT(IPOP-1)+VFITO(IPOP)
        SUM=SUM+VFITO(IPOP)
    ENDDO
    VAFIT=VAFIT/SUM
    DO WHILE(IPOS.LT.NPOP)
        ! 1st parent
        CALL RANDOM_NUMBER(RANDN)
        DO IPOP=1,NPOP
            IF(VAFIT(IPOP).GE.RANDN)THEN
                PAR(1,:)=POPO(IPOP,:)
                GOTO 10
            ENDIF
        ENDDO
        ! 2nd parent
10      CALL RANDOM_NUMBER(RANDN)
        DO JPOP=1,NPOP
            IF(VAFIT(JPOP).GE.RANDN)THEN
                IF(JPOP.EQ.IPOP)GOTO 10
                PAR(2,:)=POPO(JPOP,:)
                GOTO 15
            ENDIF
        ENDDO
        ! Position for crossover: NTBIT possible positions
15      CALL RANDOM_NUMBER(RANDN)
        RANDN=RANDN*(NTBIT-1)
        NPOS=CEILING(RANDN)
        ! Sons stored in new population vector
        ! 1st son
        IPOS=IPOS+1
        IF(IPOS.GT.NPOP)GOTO 99
        POP(IPOS,1:NPOS)=PAR(1,1:NPOS)
        POP(IPOS,NPOS+1:NTBIT)=PAR(2,NPOS+1:NTBIT)
        ! 2nd
        IPOS=IPOS+1
        IF(IPOS.GT.NPOP)GOTO 99
        POP(IPOS,1:NPOS)=PAR(2,1:NPOS)
        POP(IPOS,NPOS+1:NTBIT)=PAR(1,NPOS+1:NTBIT)
    ENDDO
99  CONTINUE
END SUBROUTINE


 SUBROUTINE DGTSV1_F95( DL, D, DU, B, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => DP
    USE LA_AUXMOD, ONLY: ERINFO
    USE F77_LAPACK, ONLY: GTSV_F77 => LA_GTSV
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    REAL(WP), INTENT(INOUT) :: DL(:), D(:), DU(:), B(:)
!   .. PARAMETERS ..
    CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GTSV'
!   .. LOCAL SCALARS ..
    INTEGER :: LINFO, N
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0
    N = SIZE(D)
!   .. TEST THE ARGUMENTS
    IF( SIZE( DL ) /= N-1 .AND. N/=0 ) THEN; LINFO = -1
    ELSE IF( N < 0 ) THEN; LINFO = -2
    ELSE IF( SIZE( DU ) /= N-1 .AND. N/=0 ) THEN; LINFO = -3
    ELSE IF( SIZE( B ) /= N ) THEN; LINFO = -4
    ELSE IF ( N > 0 ) THEN
       CALL GTSV_F77( N, 1, DL, D, DU, B, N, LINFO )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO )
 END SUBROUTINE DGTSV1_F95


module ConstitutiveModelClass
    use, intrinsic :: iso_fortran_env
    use MathClass
    use StressClass

    implicit none
    type :: ConstitutiveModel_
        type(Stress_) :: Stress
        type(Strain_) :: Strain
        logical :: infinitesimal
    contains
        !procedure,public :: MCDP => MCDP_model
        !procedure,public :: CamClay => CamClay_model
        !procedure,public :: Jaumann => Jaumann_model
        !procedure,public :: Oldroyd => Oldroyd_model
        !procedure,public :: MCDP => MCDP_model
        !procedure,public :: CamClay => CamClay_model
        !procedure,public :: Jaumann => Jaumann_model
        !procedure,public :: Oldroyd => Oldroyd_model

    end type

    type :: ConstModel_
        real(real64),allocatable::sigma(:,:)
        real(real64),allocatable::S_IJ(:,:)
        real(real64),allocatable::M_IJ(:,:)
        real(real64),allocatable::tau(:,:)
        real(real64),allocatable::F_iJ(:,:)
        real(real64),allocatable::F_T(:,:)
        real(real64),allocatable::F_iJ_n(:,:)
        real(real64),allocatable::F_inv_iJ(:,:)
        real(real64),allocatable::F_T_inv_iJ(:,:)
        real(real64),allocatable::Fp_iJ(:,:)
        real(real64),allocatable::FT_Ij(:,:)
        real(real64),allocatable::b_ij(:,:)
        real(real64),allocatable::C_IJ(:,:)
        real(real64),allocatable::C_IJ_n(:,:)
        real(real64),allocatable::C_IJ_inv(:,:)
        real(real64),allocatable::E_IJ(:,:)
        real(real64),allocatable::Cp_IJ(:,:)
        real(real64),allocatable::Cp_IJ_inv(:,:)
        real(real64),allocatable::Cp_IJ_n(:,:)
        real(real64),allocatable::Bmat(:,:)

        real(real64),allocatable::StressDer(:,:,:,:)

        real(real64) :: detF
        real(real64) :: lamda
        real(real64) :: mu
        real(real64) :: K_mod
        real(real64) :: G_mod

        character*70::ModelType
        character*70::Config
    contains
        procedure,public :: getStress => HyperElasticStress
        procedure,public :: getStressDer => HyperElasticDer
    end type

contains
!#########################################################################
subroutine HyperElasticStress(obj)
    Class(ConstModel_),intent(inout)::obj
    real(real64) :: a(3,3),delta(3,3)

    delta(:,:)=0.0d0
    delta(1,1)=1.0d0
    delta(2,2)=1.0d0
    delta(3,3)=1.0d0
    if(obj%mu==0)then
        stop "ERROR :: HyperElasticStress >> mu ==0"
    endif
    obj%K_mod=obj%lamda*(1.0d0 +     obj%mu)/3.0d0/obj%mu
    obj%G_mod=obj%lamda*(1.0d0-2.0d0*obj%mu)/2.0d0/obj%mu

    obj%detF=det_mat(obj%F_iJ,3)

    if(obj%detF==0.0d0)then
        stop "ERROR :: HyperElasticStress >> detF=0.0d0"
    endif

    if(obj%ModelType/=obj%ModelType)then
        stop "ERROR :: HyperElasticStress >> Please set obj%ModelType"
    endif

    if(trim(obj%ModelType)=="StVenantKirchhoff" )then
        if(.not.allocated(obj%sigma) )then
            allocate(obj%sigma(3,3) )
        endif
        if(.not.allocated(obj%tau) )then
            allocate(obj%tau(3,3) )
        endif
        a(:,:)=obj%b_ij(:,:)-delta(:,:)
        obj%tau(:,:)=0.50d0*obj%lamda*(obj%b_ij(1,1)+obj%b_ij(2,2)+obj%b_ij(3,3) -3.0d0 )*obj%b_ij(:,:)&
            + obj%mu*matmul(obj%b_ij, a )
        obj%sigma(:,:)=1.0d0/det_mat(obj%F_iJ, size(obj%F_iJ,1))*obj%tau(:,:)

    elseif(trim(obj%ModelType)=="NeoHookean" )then
        if(.not.allocated(obj%sigma) )then
            allocate(obj%sigma(3,3) )
        endif
        if(.not.allocated(obj%tau) )then
            allocate(obj%tau(3,3) )
        endif
        obj%tau(:,:)=obj%lamda*(log(obj%detF) )*delta(:,:) + obj%mu*(obj%b_ij(:,:)-delta(:,:) )
        obj%sigma(:,:)=1.0d0/obj%detF*obj%tau(:,:)
    elseif(trim(obj%ModelType)=="ModifiedNeoHookean_Simo" )then
        if(.not.allocated(obj%sigma) )then
            allocate(obj%sigma(3,3) )
        endif
        if(.not.allocated(obj%tau) )then
            allocate(obj%tau(3,3) )
        endif
        obj%tau(:,:)=0.50d0*obj%lamda*((obj%detF)*(obj%detF)-1.0d0 )*delta(:,:) &
            + obj%mu*(obj%b_ij(:,:)-delta(:,:) )
        obj%sigma(:,:)=1.0d0/obj%detF*obj%tau

    elseif(trim(obj%ModelType)=="ModifiedNeoHookean_Vlad" )then
        if(.not.allocated(obj%sigma) )then
            allocate(obj%sigma(3,3) )
        endif
        if(.not.allocated(obj%tau) )then
            allocate(obj%tau(3,3) )
        endif

        obj%tau(:,:)=0.50d0*obj%lamda*((obj%detF)*(obj%detF)-1.0d0 )*delta(:,:) &
            + obj%mu*(obj%b_ij(:,:)-delta(:,:) )
        obj%sigma(:,:)=1.0d0/obj%detF*obj%tau
    else
        print *, "Sorry, the model ",trim(obj%ModelType)," is not implemented yet."
        stop
    endif
end subroutine
!#########################################################################

!#########################################################################
subroutine HyperElasticDer(obj,DerType)
    Class(ConstModel_),intent(inout)::obj
    character*70,intent(in)::DerType
    real(real64) :: a(3,3),a1(3,3),delta(3,3)
    integer(int32) :: i,j,k,l

    delta(:,:)=0.0d0
    delta(1,1)=1.0d0
    delta(2,2)=1.0d0
    delta(3,3)=1.0d0
    if(obj%mu==0)then
        stop "ERROR :: HyperElasticStress >> mu ==0"
    endif

    obj%K_mod=obj%lamda*(1.0d0 +     obj%mu)/3.0d0/obj%mu
    obj%G_mod=obj%lamda*(1.0d0-2.0d0*obj%mu)/2.0d0/obj%mu

    if(obj%detF/=obj%detF)then
        obj%detF=det_mat(obj%F_iJ,3)
    endif
    if(obj%detF==0.0d0)then
        stop "ERROR :: HyperElasticStress >> detF=0.0d0"
    endif

    if(obj%ModelType/=obj%ModelType)then
        stop "ERROR :: HyperElasticStress >> Please set obj%ModelType"
    endif

    if(trim(obj%ModelType)=="StVenantKirchhoff" )then
        if(.not.allocated(obj%StressDer) )then
            allocate(obj%StressDer(3,3,3,3) )
        endif
        if(trim(DerType)=="F" .or. trim(DerType)=="F_iJ"  )then
            obj%StressDer(:,:,:,:)=0.0d0
            do i=1,3
                do j=1,3
                    do k=1,3
                        do l=1,3

                            a(:,:)=matmul(obj%b_ij,obj%F_ij)
                            a1(:,:)=matmul(obj%b_ij,trans2(obj%F_ij))
                            obj%StressDer(i,j,k,l)=obj%StressDer(i,j,k,l)&
                            -0.50d0/obj%detF*obj%F_inv_ij(l,k)*(trace(obj%b_ij)-3.0d0 )*obj%b_ij(i,j)*obj%lamda&
                            +0.50d0/obj%detF*delta(k,l)*obj%b_ij(i,j)*obj%lamda&
                            +0.50d0/obj%detF*(trace(obj%b_ij) - 3.0d0 )*(delta(i,k)*obj%F_ij(j,l)+&
                            obj%F_ij(i,l)*delta(j,k) )*obj%lamda&
                            +obj%mu*(-delta(i,k)*obj%F_ij(j,l)+obj%F_ij(i,l)*obj%b_ij(k,j) )&
                            +obj%mu*( obj%F_ij(j,l)*obj%b_ij(i,k) + a(i,l)*delta(j,k)  )
                        enddo
                    enddo
                enddo
            enddo
        elseif(trim(DerType)=="c_current" .or. trim(DerType)=="cc"  )then
            obj%StressDer(:,:,:,:)=0.0d0

            do i=1,3
                do j=1,3
                    do k=1,3
                        do l=1,3
                            obj%StressDer(i,j,k,l)=obj%StressDer(i,j,k,l)&
                           + obj%lamda*obj%b_ij(i,j)*obj%b_ij(k,l)&
                           + obj%mu*obj%b_ij(i,k)*obj%b_ij(j,l)&
                           + obj%mu*obj%b_ij(i,l)*obj%b_ij(j,k)
                        enddo
                    enddo
                enddo
            enddo
        else
            stop "ERROR :: HyperElasticStress >> no such der"
        endif
    elseif(trim(obj%ModelType)=="NeoHookean" )then
        if(.not.allocated(obj%StressDer) )then
            allocate(obj%StressDer(3,3,3,3) )
        endif
        if(trim(DerType)=="F" .or. trim(DerType)=="F_iJ"  )then
            obj%StressDer(:,:,:,:)=0.0d0
            do i=1,3
                do j=1,3
                    do k=1,3
                        do l=1,3
                            obj%StressDer(i,j,k,l)=obj%StressDer(i,j,k,l)&
                            -obj%lamda/obj%detF*obj%F_inv_iJ(l,k)*log(obj%detF)*delta(i,j)&
                            +obj%lamda/obj%detF*obj%F_inv_iJ(l,k)*delta(i,j)&
                            -obj%mu/obj%detF*obj%F_inv_iJ(l,k)*(obj%b_ij(i,j)-delta(i,j) )&
                            +obj%mu/obj%detF*(delta(i,k)*obj%F_ij(l,j) + delta(j,l)*obj%F_ij(i,k))

                        enddo
                    enddo
                enddo
            enddo

        elseif(trim(DerType)=="c_current" .or. trim(DerType)=="cc"  )then
            obj%StressDer(:,:,:,:)=0.0d0

            do i=1,3
                do j=1,3
                    do k=1,3
                        do l=1,3
                            obj%StressDer(i,j,k,l)=obj%StressDer(i,j,k,l)&
                           + obj%lamda*delta(i,j)*delta(k,l)&
                           + (obj%mu - obj%lamda*(log(obj%detF) )) * ( delta(i,k)*delta(j,l))&
                           + (obj%mu - obj%lamda*(log(obj%detF) )) * ( delta(i,l)*delta(k,j))
                        enddo
                    enddo
                enddo
            enddo
        else
            stop "ERROR :: HyperElasticStress >> no such der"
        endif
    elseif(trim(obj%ModelType)=="ModifiedNeoHookean_Simo" )then
        if(.not.allocated(obj%StressDer) )then
            allocate(obj%StressDer(3,3,3,3) )
        endif
        if(trim(DerType)=="F" .or. trim(DerType)=="F_iJ"  )then
            obj%StressDer(:,:,:,:)=0.0d0
            do i=1,3
                do j=1,3
                    do k=1,3
                        do l=1,3
                            obj%StressDer(i,j,k,l)=obj%StressDer(i,j,k,l)&
                            -obj%lamda/2.0d0*( obj%detF + 1.0d0/obj%detF  )*obj%F_inv_iJ(l,k)*delta(i,j)&
                            -obj%mu/obj%detF*obj%F_inv_iJ(l,k)*(obj%b_ij(i,j)-delta(i,j) )&
                            +obj%mu/obj%detF*(delta(i,k)*obj%F_ij(l,j) + delta(j,l)*obj%F_ij(i,k))
                        enddo
                    enddo
                enddo
            enddo
        else
            stop "ERROR :: HyperElasticStress >> no such der"
        endif
    elseif(trim(obj%ModelType)=="ModifiedNeoHookean_Vlad" )then
        if(.not.allocated(obj%StressDer) )then
            allocate(obj%StressDer(3,3,3,3) )
        endif
        if(trim(DerType)=="F" .or. DerType=="F_iJ"  )then
            obj%StressDer(:,:,:,:)=0.0d0
            do i=1,3
                do j=1,3
                    do k=1,3
                        do l=1,3
                            obj%StressDer(i,j,k,l)=obj%StressDer(i,j,k,l)&
                            -obj%lamda/2.0d0*( obj%detF + 1.0d0/obj%detF  )*obj%F_inv_iJ(l,k)*delta(i,j)&
                            -obj%mu/obj%detF*obj%F_inv_iJ(l,k)*(obj%b_ij(i,j)-delta(i,j) )&
                            +obj%mu/obj%detF*(delta(i,k)*obj%F_ij(l,j) + delta(j,l)*obj%F_ij(i,k))
                        enddo
                    enddo
                enddo
            enddo
        else
            stop "ERROR :: HyperElasticStress >> no such der"
        endif
    else
        print *, "Sorry, the model ",trim(obj%ModelType)," is not implemented yet."
        stop
    endif
end subroutine
!#########################################################################

end module


	PROGRAM DCACCONV
C
C	INPUT IS SIGNAL FROM CHANNELS 7 TO 10
C	OUTPUT IS CALCULATED RESPONSE FROM CHANNELS 3 TO 6, TAKING INTO
C	ACCOUNT THE FREQUENCY RESPONSE OF THE FFTAMP
C
	REAL SIG,DATA(1025)
	COMPLEX FCOEF,CGAIN,CCORR
	COMMON /GAINBLK/ PHASE,CGAIN                   ! PHASE IS IN RADIANS
	real ffund(3)
	data ffund /21.34766,5.336914,.3335571/

C
	ICH = 3
c	SPS = FFUND(2)*1024.
	SPS = FFUND(3)*1024.
C
	OPEN(UNIT=77,NAME='XANT.DAT',TYPE='OLD',READONLY)
	DO NN = 1,1024
	  READ(77,*) J,SIG
	  DATA(NN) = SIG
 	ENDDO
C
	CALL REALFT(DATA,512,1)
C
C	CORRECT FOURIER ANALYSED SIGNAL FOR FREQUENCY RESPONSE
C
	     DO IK = 3,1024,2
		FCOEF = CMPLX(DATA(IK),DATA(IK+1))
	        FREQ = SPS*(IK-1)/2048.
	        EJUNK = FFTAMP(ICH,FREQ)
		FCOEF = FCOEF*CGAIN
		CCORR = CGAIN
		DATA(IK) = FCOEF
		DATA(IK+1) = AIMAG(FCOEF)
		WRITE(79,*) FREQ,CABS(CGAIN),CGAIN
	     ENDDO
C
C	NOW DATA CONTAINS FOURIER COEFFS CORRECTED FOR FREQUENCY RESPONSE
C
	TYPE*,'AFTER CORRECTING'
	TYPE*,(DATA(I),I=1,10)
	TYPE*,(DATA(I),I=1020,1025)
C
C
C
	     CALL REALFT(DATA,512,-1)
	     DO IK = 1,1024
	       DATA(IK) = DATA(IK)/512.
		WRITE(78,*) IK,DATA(IK)
	     ENDDO
	STOP
	END


	subroutine chand (xphi,xmuv,xmus,xtau
     s			,xrray)
c input parameters: xphi,xmus,xmuv,xtau
c xphi: azimuthal difference between sun and observation (xphi=0,
c in backscattering) and expressed in degree (0.:360.)
c xmus: cosine of the sun zenith angle
c xmuv: cosine of the observation zenith angle
c xtau: molecular optical depth
c output parameter: xrray : molecular reflectance (0.:1.)
c constant : xdep: depolarization factor (0.0279)
	real xdep,pl(10)
	real fs0,fs1,fs2
	real as0(10),as1(2),as2(2)
        real xphi,xmus,fac,xmuv,xtau,xrray,pi,phios,xcosf1,xcosf2
        real xcosf3,xbeta2,xfd,xph1,xph2,xph3,xitm, xp1, xp2, xp3
        real cfonc1,cfonc2,cfonc3,xlntau,xitot1,xitot2,xitot3
        integer i
	data (as0(i),i=1,10) /.33243832,-6.777104e-02,.16285370
     s	,1.577425e-03,-.30924818,-1.240906e-02,-.10324388
     s	,3.241678e-02,.11493334,-3.503695e-02/
	data (as1(i),i=1,2) /.19666292, -5.439061e-02/
	data (as2(i),i=1,2) /.14545937,-2.910845e-02/
	pi=3.1415927
	fac=pi/180.
	phios=180.-xphi
	xcosf1=1.
	xcosf2=cos(phios*fac)
	xcosf3=cos(2*phios*fac)
	xbeta2=0.5
	xdep=0.0279
	xfd=xdep/(2-xdep)
	xfd=(1-xfd)/(1+2*xfd)
	xph1=1+(3*xmus*xmus-1)*(3*xmuv*xmuv-1)*xfd/8.
	xph2=-xmus*xmuv*sqrt(1-xmus*xmus)*sqrt(1-xmuv*xmuv)
	xph2=xph2*xfd*xbeta2*1.5
	xph3=(1-xmus*xmus)*(1-xmuv*xmuv)
	xph3=xph3*xfd*xbeta2*0.375
	xitm=(1-exp(-xtau*(1/xmus+1/xmuv)))*xmus/(4*(xmus+xmuv))
	xp1=xph1*xitm
	xp2=xph2*xitm
	xp3=xph3*xitm
	xitm=(1-exp(-xtau/xmus))*(1-exp(-xtau/xmuv))
	cfonc1=xph1*xitm
	cfonc2=xph2*xitm
	cfonc3=xph3*xitm
	xlntau=log(xtau)
	pl(1)=1.
	pl(2)=xlntau
	pl(3)=xmus+xmuv
	pl(4)=xlntau*pl(3)
	pl(5)=xmus*xmuv
	pl(6)=xlntau*pl(5)
	pl(7)=xmus*xmus+xmuv*xmuv
	pl(8)=xlntau*pl(7)
	pl(9)=xmus*xmus*xmuv*xmuv
	pl(10)=xlntau*pl(9)
	fs0=0.
	do i=1,10
	fs0=fs0+pl(i)*as0(i)
	enddo
	fs1=pl(1)*as1(1)+pl(2)*as1(2)
	fs2=pl(1)*as2(1)+pl(2)*as2(2)
	xitot1=xp1+cfonc1*fs0*xmus
	xitot2=xp2+cfonc2*fs1*xmus
	xitot3=xp3+cfonc3*fs2*xmus
	xrray=xitot1*xcosf1
	xrray=xrray+xitot2*xcosf2*2
	xrray=xrray+xitot3*xcosf3*2
	xrray=xrray/xmus
	return
	end


SUBROUTINE I_and_J_representations(j_x,j_y,j_z,I_x,I_y,I_z,L,S,I)

  USE FUNCIONES

  IMPLICIT  NONE
  DOUBLE PRECISION, DIMENSION(:,:),INTENT(INOUT) :: j_x,j_y,j_z,I_x,I_y,I_z
  DOUBLE PRECISION, INTENT(IN) :: L,S,I

  DOUBLE PRECISION J,F,M,M_,mI,mI_,mJ,mJ_
  INTEGER :: r,p,k,v
  J = L+S
  r = 0
  p = 0
  j_x = 0
  j_y = 0
  j_z = 0
  I_x = 0
  I_y = 0
  I_z = 0

  DO k=1,int(2*(I+S)+1)
     M  = I+S - (k-1)
     mJ = J
     mI = M-J
     if(abs(mI).GT.I)  then
        mJ = -J
        mI = M + J
     end if
     DO WHILE ((mJ.GE.-J).AND.(ABS(mI).LE.I))
        r = r + 1
        p = 0
        DO v=1,int(2*(I+S)+1)
           M_ = I+S - (v-1)
           mJ_ = J
           mI_ = M_ - J
           if(abs(mI_).GT.I) THEN
              mJ_ = -J
              mI_ = M_ + J
           END if
           DO WHILE ((mJ_.GE.-J) .AND. (ABS(mI_).LE.I))
              p = p + 1
              j_x(r,p) = 0.5*(sqrt((J-mJ_)*(J+mJ_+1))*delta_kr(mJ,mJ_+1) + &
                   & sqrt((J+mJ_)*(J-mJ_+1))*delta_kr(mJ,mJ_-1))*delta_kr(mI,mI_)
              j_y(r,p) = 0.5*(sqrt((J-mJ_)*(J+mJ_+1))*delta_kr(mJ,mJ_+1) - &
                   & sqrt((J+mJ_)*(J-mJ_+1))*delta_kr(mJ,mJ_-1))*delta_kr(mI,mI_)
              j_z(r,p) = mJ_*delta_kr(mJ,mJ_)*delta_kr(mI,mI_)

              I_x(r,p) = 0.5*(sqrt((I-mI_)*(I+mI_+1))*delta_kr(mI,mI_+1) + &
                   & sqrt((I+mI_)*(I-mI_+1))*delta_kr(mI,mI_-1))*delta_kr(mJ,mJ_)
              I_y(r,p) = 0.5*(sqrt((I-mI_)*(I+mI_+1))*delta_kr(mI,mI_+1) - &
                   & sqrt((I+mI_)*(I-mI_+1))*delta_kr(mI,mI_-1))*delta_kr(mJ,mJ_)
              I_z(r,p) = mI_*delta_kr(mJ,mJ_)*delta_kr(mI,mI_)
              !write(*,*) r,p,mI,mJ,mI_,mJ_,j_z(r,p)
              mJ_ = mJ_ - 1
              mI_ = mI_ + 1

           END DO
        END DO
        mJ = mJ - 1
        mI = mI + 1
     END DO
  END DO
END SUBROUTINE I_and_J_representations


	SUBROUTINE XFGSE(TMCH,NSYS,NPT,SPINRATE,SPSS,AANG,XDATA,XGSE)
C
C	THIS TRANSFORMS THE ELECTRIC FIELD INTO THE GSE SYSTEM
C	THE INPUT IS THE ELECTRIC FIELD IN THE SPACECRAFT ANTENNA
C	SYSTEM IN XDATA, THE OUTPUT, IN XGSE, IS THE ELECTRIC FIELD IN
C	THE GSE SYSTEM.  NOTE THAT THE S/C IS UPSIDE DOWN, SO THAT IF
C	+EX POINTS AT THE SUN (ANG=0) THEN +EY POINTS IN THE - Y (GSE)
C	DIRECTION
C	NPT IS THE NUMBER OF DATA POINTS IN A SERIES
C	NSYS = 1 IS ANTENNA SYSTEM, = 2 IS ? SYSTEM, = 3 IS ? SYSTEM
C
	INTEGER*4 NSYS
	INTEGER*4 OK,OKT,TMCH,W_ITEM_I4,W_ITEM_R4,W_ITEM_R8
	character*32	item
C	COMMON /PARTBLK/ XDATA(2050,4),XFDATA(2050,4),XGSE(2050,4),
C     1		XRE,YRE,ZRE,SUNCLOCK,SPINRATE,SPSS
	REAL XDATA(2050,4),XGSE(2050,4)
	COMMON /VARMATX/ EVAL(3),EVECT(3,3)
	DATA TWOPI /6.2831853/
C
C	  THE FIELDS ARE IN THE ANTENNA SYSTEM
C	  TRANSFORM THEM TO THE GSE SYSTEM, EX, EY, EZ, BY ROTATING
C	  X AND Y, and INVERTING  Z gse is parallel to Z ant already,
C	   but opposite
C
	NSYS = 3
C	WRITE(79,*) ' '
C	WRITE(79,*) 'XFGSE CALLED--E DATA PUT INTO GSE SYSTEM, NSYS=3'
C
C	ANGLE =  -360.*SUNCLOCK/4096. - 45.       ! ANGLE SUN TO +EX AT END
	DANG = SPINRATE*360./SPSS/TWOPI
	ANGLE = AANG + NPT*DANG		  ! ANGLE SUN TO +EX AT START
	DO N = 1,NPT
		ANGLE = ANGLE - DANG
	        SINANG = SIND(ANGLE)
	        COSANG = COSD(ANGLE)
		XGSE(N,1) = XDATA(N,1)*COSANG + XDATA(N,2)*SINANG
		XGSE(N,2) =-XDATA(N,2)*COSANG + XDATA(N,1)*SINANG
		XGSE(N,3) = -XDATA(N,3)
	ENDDO
C
C	NOW XGSE ARE IN THE GSE SYSTEM
C
	RETURN
	END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine shape15w(xi,et,ze,xl,xsj,shp,iflag)
!
!     shape functions and derivatives for a 15-node quadratic
!     isoparametric wedge element. 0<=xi,et<=1,-1<=ze<=1,xi+et<=1.
!
!     iflag=1: calculate only the value of the shape functions
!     iflag=2: calculate the value of the shape functions and
!              the Jacobian determinant
!     iflag=3: calculate the value of the shape functions, the
!              value of their derivatives w.r.t. the global
!              coordinates and the Jacobian determinant
!
!
!     Copyright (c) 2003 WB
!
!     Written February 2003 on the basis of the Guido's shape function files
!
      implicit none
!
      integer i,j,k,iflag
!
      real*8 shp(4,15),xs(3,3),xsi(3,3),xl(3,15),sh(3)
!
      real*8 xi,et,ze,xsj,a
!
!
!
!     shape functions and their glocal derivatives
!
      a=1.d0-xi-et
!
!     shape functions
!
      shp(4,1)=-0.5d0*a*(1.d0-ze)*(2.d0*xi+2.d0*et+ze)
      shp(4,2)=0.5d0*xi*(1.d0-ze)*(2.d0*xi-2.d0-ze)
      shp(4,3)=0.5d0*et*(1.d0-ze)*(2.d0*et-2.d0-ze)
      shp(4,4)=-0.5d0*a*(1.d0+ze)*(2.d0*xi+2.d0*et-ze)
      shp(4,5)=0.5d0*xi*(1.d0+ze)*(2.d0*xi-2.d0+ze)
      shp(4,6)=0.5d0*et*(1.d0+ze)*(2.d0*et-2.d0+ze)
      shp(4,7)=2.d0*xi*a*(1.d0-ze)
      shp(4,8)=2.d0*xi*et*(1.d0-ze)
      shp(4,9)=2.d0*et*a*(1.d0-ze)
      shp(4,10)=2.d0*xi*a*(1.d0+ze)
      shp(4,11)=2.d0*xi*et*(1.d0+ze)
      shp(4,12)=2.d0*et*a*(1.d0+ze)
      shp(4,13)= a*(1.d0-ze*ze)
      shp(4,14)=xi*(1.d0-ze*ze)
      shp(4,15)=et*(1.d0-ze*ze)
!
      if(iflag.eq.1) return
!
!     local derivatives of the shape functions: xi-derivative
!
      shp(1,1)=  0.5d0*(1.d0-ze)*(4.0d0*xi+4.0d0*et+ze-2.d0)
      shp(1,2)=  0.5d0*(1.d0-ze)*(4.0d0*xi-ze-2.d0)
      shp(1,3)=  0.d0
      shp(1,4)=  0.5d0*(1.d0+ze)*(4.0d0*xi+4.0d0*et-ze-2.d0)
      shp(1,5)=  0.5d0*(1.d0+ze)*(4.0d0*xi+ze-2.d0)
      shp(1,6)=  0.d0
      shp(1,7)=  2.d0*(1.d0-ze)*(1.d0-2.d0*xi-et)
      shp(1,8)=  2.d0*et*(1.d0-ze)
      shp(1,9)= -2.d0*et*(1.d0-ze)
      shp(1,10)= 2.d0*(1.d0+ze)*(1.d0-2.d0*xi-et)
      shp(1,11)= 2.d0*et*(1.d0+ze)
      shp(1,12)= -2.d0*et*(1.d0+ze)
      shp(1,13)= -(1.d0-ze*ze)
      shp(1,14)=  (1.d0-ze*ze)
      shp(1,15)=  0.d0
!
!     local derivatives of the shape functions: eta-derivative
!
      shp(2,1)=  0.5d0*(1.d0-ze)*(4.0d0*xi+4.0d0*et+ze-2.d0)
      shp(2,2)= 0.d0
      shp(2,3)= 0.5d0*(1.d0-ze)*(4.0d0*et-ze-2.d0)
      shp(2,4)= 0.5d0*(1.d0+ze)*(4.0d0*xi+4.0d0*et-ze-2.d0)
      shp(2,5)= 0.d0
      shp(2,6)= 0.5d0*(1.d0+ze)*(4.0d0*et+ze-2.d0)
      shp(2,7)=-2.d0*xi*(1.d0-ze)
      shp(2,8)= 2.d0*xi*(1.d0-ze)
      shp(2,9)= 2.d0*(1.d0-ze)*(1.d0-xi-2.d0*et)
      shp(2,10)=-2.d0*xi*(1.d0+ze)
      shp(2,11)= 2.d0*xi*(1.d0+ze)
      shp(2,12)= 2.d0*(1.d0+ze)*(1.d0-xi-2.d0*et)
      shp(2,13)=-(1.d0-ze*ze)
      shp(2,14)= 0.0d0
      shp(2,15)= (1.d0-ze*ze)
!
!     local derivatives of the shape functions: zeta-derivative
!
      shp(3,1)=  a*(xi+et+ze-0.5d0)
      shp(3,2)= xi*(-xi+ze+0.5d0)
      shp(3,3)= et*(-et+ze+0.5d0)
      shp(3,4)=  a*(-xi-et+ze+0.5d0)
      shp(3,5)= xi*(xi+ze-0.5d0)
      shp(3,6)= et*(et+ze-0.5d0)
      shp(3,7)= -2*xi*a
      shp(3,8)= -2*xi*et
      shp(3,9)= -2*et*a
      shp(3,10)= 2*xi*a
      shp(3,11)= 2*xi*et
      shp(3,12)= 2*et*a
      shp(3,13)=-2*a*ze
      shp(3,14)=-2*xi*ze
      shp(3,15)=-2*et*ze
!
!     computation of the local derivative of the global coordinates
!     (xs)
!
      do i=1,3
        do j=1,3
          xs(i,j)=0.d0
          do k=1,15
            xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k)
          enddo
        enddo
      enddo
!
!     computation of the jacobian determinant
!
      xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2))
     &   -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1))
     &   +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1))
!
      if(iflag.eq.2) return
!
!     computation of the global derivative of the local coordinates
!     (xsi) (inversion of xs)
!
      xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj
      xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj
      xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj
      xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj
      xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj
      xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj
      xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj
      xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj
      xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj
!
!     computation of the global derivatives of the shape functions
!
      do k=1,15
        do j=1,3
          sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j)
        enddo
        do j=1,3
          shp(j,k)=sh(j)
        enddo
      enddo
!
      return
      end


! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
PROGRAM TEST
  USE ISO_FORTRAN_ENV, ONLY: REAL32
  USE PLRM
  USE TIMER, ONLY: START_TIMER, STOP_TIMER, TOTAL, RESET_TIMER
  IMPLICIT NONE
  ! Global settings.
  INTEGER, PARAMETER :: N = 2**3, DI = 2**1, DO = 1
  REAL(KIND=REAL32), PARAMETER :: PI = 3.1415926535897932
  INTEGER, PARAMETER :: DS = 3, NS = 2, STEPS = 20
  ! Local variables.
  REAL(KIND=REAL32), DIMENSION(:,:), ALLOCATABLE :: X, Y
  REAL(KIND=REAL32), DIMENSION(:), ALLOCATABLE :: MEAN, STDEV
  REAL(KIND=REAL32) :: MSE
  INTEGER :: I
  INTEGER, DIMENSION(:), ALLOCATABLE :: SEED_ARRAY
  WRITE (*,*) ' '
  CALL RESET_TIMER()

  ! Set a random seed, if one was provided (otherwise leave default).
  CALL RANDOM_SEED(SIZE=I)
  ALLOCATE(SEED_ARRAY(I))
  SEED_ARRAY(:) = 0
  CALL RANDOM_SEED(PUT=SEED_ARRAY(:))

  WRITE (*,*) 'Allocating storage..'
  CALL START_TIMER()
  ALLOCATE(X(1:DI,1:N), Y(1:DO,1:N), MEAN(1:DI), STDEV(1:DI))
  CALL STOP_TIMER()
  ! WRITE (*,'("  ",1F10.6,/)') TOTAL()

  WRITE (*,*) 'Creating and initializing new model..'
  CALL START_TIMER()
  CALL NEW_MODEL(DI, DS, NS, DO)
  CALL INIT_MODEL(SEED=0)
  CALL STOP_TIMER()
  ! WRITE (*,'("  ",1F10.6,/)') TOTAL()

  WRITE (*,*) 'Generating training data..'
  CALL START_TIMER()
  ! Generate random X and Y values.
  CALL RANDOM_NUMBER(X(:,:))
  X(:,:) = 2.0_REAL32 * PI * X(:,:)
  DO I = 1, DO
     Y(DO,:) = REAL(I-1,REAL32) + SIN(NORM2(X(:,:), DIM=1))
  END DO
  CALL STOP_TIMER()
  ! WRITE (*,'("  ",1F10.6,/)') TOTAL()

  WRITE (*,*) 'Normalizing input data to have zero mean and unit variance..'
  CALL START_TIMER()
  ! Make the X data unit mean.
  MEAN(:) = SUM(X(:,:), DIM=2) / REAL(N,REAL32)
  DO I = 1, DI
     X(I,:) = X(I,:) - MEAN(I)
  END DO
  ! Make the X data unit variance.
  STDEV(:) = SQRT(SUM(X(:,:)**2, DIM=2) / REAL(N,REAL32))
  DO I = 1, DI
     IF (STDEV(I) .EQ. 0) CYCLE
     X(I,:) = X(I,:) / STDEV(I)
  END DO
  CALL STOP_TIMER()
  ! WRITE (*,'("  ",1F10.6,/)') TOTAL()

  WRITE (*,*) 'Creating and initializing new model based on data..'
  CALL START_TIMER()
  CALL NEW_MODEL(DI, DS, NS, DO)
  CALL INIT_MODEL(INPUTS=X, OUTPUTS=Y, SEED=0)
  CALL STOP_TIMER()
  ! WRITE (*,'("  ",1F10.6,/)') TOTAL()

  WRITE (*,*) 'Training model..'
  CALL START_TIMER()
  CALL MINIMIZE_MSE(X(:,:), Y(:,:), STEPS=STEPS, MEAN_SQUARED_ERROR=MSE, &
       NUM_THREADS=2)
  CALL STOP_TIMER()
  ! WRITE (*,'("  ",1F10.6,/)') TOTAL()
  WRITE (*,*) MSE

  ! WRITE (*,*) 'Time spent:'
  ! WRITE (*,"(A14,F10.6)")   '   DGEMM time: ', DGEMM_TIMER
  ! WRITE (*,"(A14,F10.6,/)") '   OTHER time: ', OTHER_TIMER

END PROGRAM TEST


        FUNCTION PR_CMSL ( ceil, selv )
C************************************************************************
C* PR_CMSL                                                              *
C*                                                                      *
C* This function computes CMSL, the ceiling converted to MSL (mean sea  *
C* level) in hundreds of feet.                                          *
C*                                                                      *
C* REAL PR_CMSL  ( CEIL, SELV )                                         *
C*                                                                      *
C* Input parameters:                                                    *
C*	CEIL 		REAL    Ceiling in hundreds of feet             *
C*      SELV		REAL	Station elevation in meters             *
C*                                                                      *
C* Output parameters:                                                   *
C*      PR_CMSL         REAL    Ceiling converted to MSL in 100's of ft *
C**                                                                     *
C* Log:                                                                 *
C* D. Kidwell/NCEP	 5/03                                           *
C************************************************************************
        INCLUDE   	'GEMPRM.PRM'
	INCLUDE	  	'ERMISS.FNC'
C------------------------------------------------------------------------
	IF ( ERMISS ( selv ) .or. ERMISS ( ceil ) ) THEN
	    PR_CMSL = RMISSD
	  ELSE
	    PR_CMSL = PR_HGMF ( selv ) / 100. + ceil
	END IF
C*
        RETURN
        END