************************************************************************
*                          OUTPUT.FOR                                  *
*                                                                      *
*  PROGRAM: SIMRAND I                                                  *
*  MODULE:  1.6                                                        *
*  DATE:    04/09/85                                                   *
*                                                                      *
*  THIS IS THE SUBROUTINE OUTPUT.  IT CALCULATES THE TOTAL STATISTICS  *
*  FOR THE RUN AND OUTPUTS THE RESULTS TO A FILE.                      *
*                                                                      *
*----------------------------------------------------------------------*
*                    CONFIGURATION CHANGES                             *
*                                                                      *
*    DATE                 CHANGE                                       *
*                                                                      *
*  01/18/85  * ORIGINAL.                                               *
*  04/09/85  * MODULE 10: REPLACE PRMIN WITH PRMAX.                    *
*                                                                      *
************************************************************************

$TITLE:'OUTPUT.LST'
$DEBUG
$NOFLOATCALLS
$STORAGE:2

************************************************************************

      SUBROUTINE OUTPUT

************************************************************************

***** INITIALIZE.  {MODULE 1}

$INCLUDE:'INITIAL.FOR'

      IF (JDIAG .NE. 0) THEN
         WRITE  (*,100)
100      FORMAT (/1X,'ENTER SUBROUTINE OUTPUT')
      ENDIF

*     PROBABILITY POINTS FOR SUMMARY CDFS.
      ZPCT(1) = 0.10
      ZPCT(2) = 0.25
      ZPCT(3) = 0.50
      ZPCT(4) = 0.75
      ZPCT(5) = 0.90

***   {END MODULE 1}

***** START DO LOOP TO CALCULATE CDFS.  {MODULE 2}

      DO 150 IP=1,NIP

*****    CALCULATE PRICEZ(IP,IZ) FOR SUMMARY CDFS.  {MODULE 3}

         DO 130 IZ=1,5

            PERCNT = FLOAT(IHPMIN(IP,1))/(NTRIAL)

            IF (PERCNT .GE. ZPCT(IZ)) THEN

               PRICEZ(IP,IZ) = PLB(IP)

            ELSEIF (PERCNT .LT. 1.00) THEN

               DO 110 IH=2,51
                  IIH = IH
                  PERCNT = PERCNT + FLOAT(IHPMIN(IP,IH))/(NTRIAL)
                  IF (PERCNT .GE. ZPCT(IZ)) GO TO 120
110            CONTINUE

120            CONTINUE

               PRICEZ(IP,IZ) = PLB(IP) +
     *                         (IIH - 1)*(PUB(IP) - PLB(IP))/50

            ELSE

               PRICEZ(IP,IZ) = PUB(IP)

            ENDIF

130      CONTINUE

***      {END MODULE 3}

*****    CALCULATE PRICE CDF(IP,IH) & PCDF(IP,IH) FOR DETAILED CDFS.
*****    {MODULE 4}

         CDF(IP,1)   = FLOAT(IHPMIN(IP,1))/(NTRIAL)
         PCDF(IP,1)  = PLB(IP)

         DO 140 IH=2,51
            CDF(IP,IH)  = CDF(IP,IH-1) + FLOAT(IHPMIN(IP,IH))/(NTRIAL)
            PCDF(IP,IH) = PLB(IP) + (IH - 1)*(PUB(IP) - PLB(IP))/50
140      CONTINUE

***      {END MODULE 4}

150   CONTINUE

***   {END MODULE 2}

***** WRITE RUN IDENTIFICATION TO FILE.  {MODULE 5}

      WRITE  (2,160) IDATA,NTRIAL,RNSEED
160   FORMAT ('IDATA = ',I5,8X,'NTRIAL = ',I5,8X,'RANDOM SEED = ',F15.0)

***   {END MODULE 5}

***** WRITE PMEAN(IP).  {MODULE 6}

      IF (NIP .LE. 5) THEN
         WRITE  (2,170) (PMEAN(IP),IP=1,NIP)
      ELSE
         WRITE  (2,170) (PMEAN(IP),IP=1,5)
         WRITE  (2,180) (PMEAN(IP),IP=6,NIP)
      ENDIF

170   FORMAT ('PMEAN',3X,1P5E14.4)
180   FORMAT (        8X,1P5E14.4)

***   {END MODULE 6}

***** WRITE PSDEV(IP).  {MODULE 7}

      IF (NIP .LE. 5) THEN
         WRITE  (2,190) (PSDEV(IP),IP=1,NIP)
      ELSE
         WRITE  (2,190) (PSDEV(IP),IP=1,5)
         WRITE  (2,200) (PSDEV(IP),IP=6,NIP)
      ENDIF

190   FORMAT ('PSDEV',3X,1P5E14.4)
200   FORMAT (        8X,1P5E14.4)

***   {END MODULE 7}

***** WRITE PRMIN(IP).  {MODULE 8}

      IF (NIP .LE. 5) THEN
         WRITE  (2,210) (PRMIN(IP),IP=1,5)
      ELSE
         WRITE  (2,210) (PRMIN(IP),IP=1,5)
         WRITE  (2,220) (PRMIN(IP),IP=6,NIP)
      ENDIF

210   FORMAT ('PRMIN',3X,1P5E14.4)
220   FORMAT (        8X,1P5E14.4)

***   {END MODULE 8}

***** WRITE PRICEZ(IP,IZ) TO FILE.  {MODULE 9}

      DO 250 IZ=1,5

         IF (NIP .LE. 5) THEN
            WRITE  (2,230) ZPCT(IZ),(PRICEZ(IP,IZ),IP=1,NIP)
         ELSE
            WRITE  (2,230) ZPCT(IZ),(PRICEZ(IP,IZ),IP=1,5)
            WRITE  (2,240)          (PRICEZ(IP,IZ),IP=6,NIP)
         ENDIF

230      FORMAT (F4.2,4X,1P5E14.4)
240      FORMAT (     8X,1P5E14.4)

250   CONTINUE

***   {END MODULE 9}

***** WRITE PRMAX(IP).  {MODULE 10}

      IF (NIP .LE. 5) THEN
         WRITE  (2,260) (PRMAX(IP),IP=1,5)
      ELSE
         WRITE  (2,260) (PRMAX(IP),IP=1,5)
         WRITE  (2,270) (PRMAX(IP),IP=6,NIP)
      ENDIF

260   FORMAT ('PRMAX',3X,1P5E14.4)
270   FORMAT (        8X,1P5E14.4)

***   {END MODULE 10}

***** WRITE RUTIL(II).  {MODULE 11}

      IF (NII .LE. 5) THEN
         WRITE  (2,280) (RUTIL(II),II=1,NII)
      ELSE
         WRITE  (2,280) (RUTIL(II),II=1,5)
         WRITE  (2,290) (RUTIL(II),II=6,NII)
      ENDIF

280   FORMAT ('RUTIL',3X,5F14.4)
290   FORMAT (        8X,5F14.4)

***   {END MODULE 11}

***** WRITE CERTEQ(II).  {MODULE 12}

      IF (NII .LE. 5) THEN
         WRITE  (2,300) (CERTEQ(II),II=1,NII)
      ELSE
         WRITE  (2,300) (CERTEQ(II),II=1,5)
         WRITE  (2,310) (CERTEQ(II),II=6,NII)
      ENDIF

300   FORMAT ('CERTEQ',2X,5F14.4)
310   FORMAT (         8X,5F14.4)

***   {END MODULE 12}

***** WRITE IHALT(IA).  {MODULE 13}

      IF (NIA .LE. 10) THEN
         WRITE (2,320) (IHALT(IA),IA=1,NIA)
      ELSE
         WRITE (2,320) (IHALT(IA),IA=1,10)
         WRITE (2,330) (IHALT(IA),IA=11,NIA)
      ENDIF

320   FORMAT ('IHALT',3X,10I5)
330   FORMAT (        8X,10I5)

***   {END MODULE 13}

***** WRITE RANDOM TO FILE.  {MODULE 14}

*     THIS VALUE OF RANDOM IS THE LAST GENERATED AND SHOULD BE USED AS
*     THE SEED (RNSEED) TO REPEAT THE RUN WITH DIFFERENT RANDOM NUMBERS.

      WRITE  (2,340) RANDOM
340   FORMAT ('RANDOM NUMBER SEED (RNSEED) FOR NEXT RUN = ',F15.0)

***   {END MODULE 14}

***** IF JLOUT = 1, WRITE DETAILED CDFS TO OUTPUT FILE.  {MODULE 15}

      IF (JLOUT .EQ. 1) THEN

*****    WRITE IH, STEP PRICE, & CDF(IP,IH) TO FILE.  {MODULE 16}

         DO 410 IP=1,NIP

            WRITE  (2,350) IP
350         FORMAT (/14X,'IH, STEP PRICE, & CDF(IP,IH) FOR IP = ',I5)

            WRITE  (2,360) PRMIN(IP),PRMAX(IP)
360         FORMAT (/6X,'PRMIN(IP) = ',1PE14.4,5X,'PRMAX(IP) = ',
     *              1PE14.4)

            WRITE  (2,370)
370         FORMAT (/'   IH ','     PRICE     ','   CDF(IP,IH)',
     *              3X,'   IH ','     PRICE     ','   CDF(IP,IH)'/)

            DO 390 IH=1,25

               IH25 = IH + 25

               WRITE (2,380) IH,  PCDF(IP,IH),  CDF(IP,IH),
     *                       IH25,PCDF(IP,IH25),CDF(IP,IH25)
380            FORMAT (2(I5,1PE14.4,0PF14.4,4X))

390         CONTINUE

            WRITE  (2,400) PCDF(IP,51),CDF(IP,51)
400         FORMAT (40X,'51',1PE14.4,0PF14.4)

410      CONTINUE

***      {END MODULE 16}

*****    WRITE IHPMIN(IP,IH) TO FILE.  {MODULE 17}

         DO 440 IP=1,NIP

            WRITE  (2,420) IP,(IHPMIN(IP,IH),IH=1,10)
            WRITE  (2,430)    (IHPMIN(IP,IH),IH=11,52)

420         FORMAT ('IHPMIN',4X,I5, 5X,10I5)
430         FORMAT (               20X,10I5)

440      CONTINUE

***      {END MODULE 17}

      ENDIF

***   {END MODULE 15}

***** EXIT FROM SUBROUTINE OUTPUT.  {MODULE 18}

      IF (JDIAG .NE. 0) THEN
         WRITE  (*,999)
999      FORMAT (1X,'EXIT  SUBROUTINE OUTPUT')
      ENDIF

      RETURN

      END

***   {END MODULE 18}

***************************** OUTPUT.FOR *******************************


      SUBROUTINE TRBAK3(NM,N,NV,A,M,Z,EPS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C               ===== PROCESSED BY AUGMENT, VERSION 4N =====
C     APPROVED FOR VAX 11/780 ON MAY 6,1980.  J.D.NEECE
C               ----- LOCAL VARIABLES -----
C               ----- GLOBAL VARIABLES -----
      DIMENSION A(NV), Z(NM,M)
C               ===== TRANSLATED PROGRAM =====
C
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC
C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
C     SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY  TRED3.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
C          AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT,
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS
C          USED IN THE REDUCTION BY  TRED3  IN ITS FIRST
C          N*(N+1)/2 POSITIONS,
C
C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED,
C
C        Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
C          IN ITS FIRST M COLUMNS.
C
C     ON OUTPUT-
C
C        Z CONTAINS THE TRANSFORMED EIGENVECTORS
C          IN ITS FIRST M COLUMNS.
C
C     NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
      IF (M .EQ. 0) GO TO 50
      IF (N .EQ. 1) GO TO 50
C
      DO 40   I = 2, N
         L = I - 1
         IZ = (I * L) / 2
         IK = IZ + I
         H = A(IK)
         IF (H.EQ.0.0D0)  GO TO 40
C
         DO 30   J = 1, M
            S=0.0D0
            IK = IZ
C
            DO 10   K = 1, L
               IK = IK + 1
               S = S + A(IK) * Z(K,J)
   10       CONTINUE
C     ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW **********
            S = (S / H) / H
            IK = IZ
C
            DO 20   K = 1, L
               IK = IK + 1
               Z(K,J) = Z(K,J) - S * A(IK)
   20       CONTINUE
C
   30    CONTINUE
C
   40 CONTINUE
C
   50 RETURN
C     ********** LAST CARD OF TRBAK3 **********
      END


*     MC01RD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DP1MAX, DP2MAX, DP3MAX
      PARAMETER        ( DP1MAX = 10, DP2MAX = 10, DP3MAX = 10 )
      INTEGER          LENP3
      PARAMETER        ( LENP3 = MAX(DP1MAX+DP2MAX,DP3MAX)+1 )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA
      INTEGER          DP1, DP2, DP3, I, INFO
*     .. Local Arrays ..
      DOUBLE PRECISION P1(DP1MAX+1), P2(DP2MAX+1), P3(LENP3)
*    $                 P3(DP1MAX+DP2MAX+DP3MAX+1)
*     .. External Subroutines ..
      EXTERNAL         MC01RD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) DP1
      IF ( DP1.LE.-2 .OR. DP1.GT.DP1MAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) DP1
      ELSE
         READ ( NIN, FMT = * ) ( P1(I), I = 1,DP1+1 )
         READ ( NIN, FMT = * ) DP2
         IF ( DP2.LE.-2 .OR. DP2.GT.DP2MAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) DP2
         ELSE
            READ ( NIN, FMT = * ) ( P2(I), I = 1,DP2+1 )
            READ ( NIN, FMT = * ) DP3
            IF ( DP3.LE.-2 .OR. DP3.GT.DP3MAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) DP3
            ELSE
               READ ( NIN, FMT = * ) ( P3(I), I = 1,DP3+1 )
            END IF
            READ ( NIN, FMT = * ) ALPHA
*           Compute the coefficients of the polynomial P(x).
            CALL MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 ) DP3
               IF ( DP3.GE.0 ) THEN
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 0, DP3
                     WRITE ( NOUT, FMT = 99995 ) I, P3(I+1)
   20             CONTINUE
               END IF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC01RD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01RD = ',I2)
99997 FORMAT (' Degree of the resulting polynomial P(x) = ',I2)
99996 FORMAT (/' The coefficients of P(x) are ',//' power of x     coe',
     $       'fficient ')
99995 FORMAT (2X,I5,9X,F9.4)
99994 FORMAT (/' DP1 is out of range.',/' DP1 = ',I5)
99993 FORMAT (/' DP2 is out of range.',/' DP2 = ',I5)
99992 FORMAT (/' DP3 is out of range.',/' DP3 = ',I5)
      END


MODULE glob_var

implicit none

integer :: i_system, &
           imax, g_neqns, g_nprim, ntstep, &
           g_nsdiscr, g_gdof, g_tdof, g_nlim, g_nmatint, &
           g_nprelx, &
           g_lbflag, g_rbflag, &
           iprob, i_restart, i_flux, n_opfile, n_screen
real*8  :: dt_u, dt, dt_s, g_time

!--- indexing into the multimaterial system
type mmindex
  integer :: nummat, iamin, iamax, irmin, irmax, imome, iemin, iemax
end type mmindex

type(mmindex) :: g_mmi

!--- flow properties
real*8  :: rho1_fs, alpha1_fs, g_alphamin
real*8  :: rho2_fs
real*8  :: u_fs, pr_fs, t_fs
real*8, allocatable  :: alpha_fs(:), rhomat_fs(:)

!--- reference quantities for nondimensionalization
real*8  :: a_nd, t_nd, p_nd, rho_nd

!--- isothermal gas
real*8, parameter :: rgas = 287.15
real*8, parameter :: tinf = 300.0
real*8  :: agas = dsqrt(rgas*tinf)

!--- Tait equation constants
real*8  :: rho0 = 1000.0
real*8  :: p0   = 101325.0
real*8  :: k0   = 2.15d9
real*8  :: n0   = 7.15

!--- stiffened gas constants
real*8, allocatable :: g_gam(:), g_cp(:), g_pc(:)

!--- interface pressure correction coeff
real*8  :: g_prelct

!--- conservation
real*8  :: g_mass0_m, g_tenergy0_m

!--- geometry
real*8,  allocatable :: coord(:)

real*8,  parameter :: Pi = 4.d0*datan(1.d0)

CONTAINS

!-----------------------------------------------------------------------
!----- MC limiter
!-----------------------------------------------------------------------

real*8 function mclim(a,b,c)
real*8,intent(in) :: a,b,c

  if ((a*b>0.0) .and. (a*c>0.0)) then
    mclim = min(2.0*dabs(a), dabs(b), 2.0*dabs(c)) * dsign(1.0,b)
  else
    mclim = 0.0
  end if

end function mclim

!-----------------------------------------------------------------------
!----- Normalized Taylor basis function calculation
!-----------------------------------------------------------------------

subroutine get_basisfns(x, xc, dx, basis)

real*8, intent(in) :: x, xc, dx

real*8, intent(out) :: basis(g_tdof)

  basis = 0.0

  !--- dgp0
  basis(1) = 1.0

  !--- rdgp0p1 or dgp1
  if (g_nsdiscr .gt. 0) basis(2) = p1basis(x, xc, dx)

  !--- rdgp1p2
  if (g_nsdiscr .gt. 11) basis(3) = p2basis(x, xc, dx)

end subroutine get_basisfns

!-----------------------------------------------------------------------

real*8 function p1basis(x,xc,dx)
real*8, intent(in) :: x, xc, dx

  p1basis = (x-xc)/(0.5*dx)

end function p1basis

!-----------------------------------------------------------------------

real*8 function p2basis(x,xc,dx)
real*8, intent(in) :: x, xc, dx
real*8 :: hdx

  hdx = 0.5*dx
  p2basis = (x-xc)*(x-xc)/(2.0*hdx*hdx) - 1.0/6.0

end function p2basis

!-----------------------------------------------------------------------
!----- Number of quadrature points for volume integral
!-----------------------------------------------------------------------

pure integer function get_numqpoints(ndiscr)
integer, intent(in) :: ndiscr

  !--- dgp0 or rdgp0p1
  if ((ndiscr == 0) .or. (ndiscr == 1)) then
    get_numqpoints = 1

  !--- dgp1 or rdgp1p2
  else if ((ndiscr == 11) .or. (ndiscr == 12)) then
    get_numqpoints = 2

  end if

end function get_numqpoints

!-----------------------------------------------------------------------
!----- Functions used to index into uprim
!-----------------------------------------------------------------------

pure integer function apr_idx(nummat, k)
integer, intent(in) :: nummat, k

  apr_idx = k

end function apr_idx

!-----------------------------------------------------------------------

pure integer function mmom_idx(nummat, k)
integer, intent(in) :: nummat, k

  mmom_idx = nummat + k

end function mmom_idx

!-----------------------------------------------------------------------

pure integer function vel_idx(nummat, idir)
integer, intent(in) :: nummat, idir

  vel_idx = 2*nummat + 1

end function vel_idx

!-----------------------------------------------------------------------

END MODULE glob_var


use LeafClass
implicit None

type(Leaf_) :: leaf
real(real64),allocatable :: ny(:),n(:)

call leaf%init()
call leaf%vtk("sample_leaf")

print *, leaf%femdomain%mesh%nodcoord(&
    leaf%A_PointNodeID,:)

print *, leaf%femdomain%mesh%nodcoord(&
    leaf%C_PointNodeID,:)

print *, leaf%femdomain%mesh%nodcoord(&
    leaf%B_PointNodeID,:)

print *, leaf%femdomain%mesh%nodcoord(&
    leaf%D_PointNodeID,:)

print *, "--"
print *, leaf%femdomain%centerPosition(ElementID=leaf%A_PointElementID)
print *, leaf%femdomain%centerPosition(ElementID=leaf%C_PointElementID)
print *, leaf%femdomain%centerPosition(ElementID=leaf%B_PointElementID)
print *, leaf%femdomain%centerPosition(ElementID=leaf%D_PointElementID)

print *, "nomal"
print *, leaf%femdomain%ne()
ny = zeros(leaf%femdomain%ne())
do j_j=1,90
    call leaf%rotate(x=radian(-1.0d0) )
    do i_i=1,leaf%femdomain%ne()
        n = leaf%getNormalVector(ElementID=i_i)
        ny(i_i) = n(2)
    enddo
    call leaf%femdomain%vtk("sample_leaf_ny"+str(j_j),scalar=ny)
enddo

end


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
module m_irjc_matrix_lag

  use my_hecmw_util_lag

  ! Handle irow, jcol type sparse matrix information.
  ! Eqch matrix element have ndeg*ndeg small matrix.
  ! The number of non-zero elements are stored in nttbr.

  type irjc_square_matrix
    ! number of equations
    integer(kind=kint) :: neqns

    ! number of non-zero elements
    integer(kind=kint) :: nttbr

    ! degree of freedom of each element
    integer(kind=kint) :: ndeg
    integer, pointer :: irow(:), jcol(:) ! irow(nttbr_t), jcol(nttbr_t) location of i'th element
    real(kind=kreal), pointer :: val(:,:) ! val(ndeg*ndeg, nttbr_t) concrete value of nonzero elements. small matrix is expanded as ndeg*ndeg.
  end type irjc_square_matrix

  type irjc_mn_matrix !m*n matrix
    ! number of rows.
    integer(kind=kint) :: nrows

    ! number of columns.
    integer(kind=kint) :: ncols

    ! number of non-zero elements
    integer(kind=kint) :: nttbr

    ! degree of freedom of each element
    integer(kind=kint) :: ndeg
    integer(kind=kint), pointer :: irow(:), jcol(:) ! irow(nttbr_t), jcol(nttbr_t) location of i'th element
    real(kind=kreal), pointer :: val(:,:) ! val(ndeg*ndeg, nttbr_t) concrete value of nonzero elements. small matrix is expanded as ndeg*ndeg.
  end type irjc_mn_matrix
end module m_irjc_matrix_lag


! { dg-do compile }

   SUBROUTINE smm_dnn_4_10_10_1_1_2_1(A,B,C)
      REAL   :: C(4,10), B(10,10), A(4,10)
      DO j=           1 ,          10 ,           2
      DO i=           1 ,           4 ,           1
      DO l=           1 ,          10 ,           1
        C(i+0,j+0)=C(i+0,j+0)+A(i+0,l+0)*B(l+0,j+0)
        C(i+0,j+1)=C(i+0,j+1)+A(i+0,l+0)*B(l+0,j+1)
      ENDDO
      ENDDO
      ENDDO
    END SUBROUTINE
   SUBROUTINE smm_dnn_4_10_10_6_4_1_1(A,B,C)
      REAL   :: C(4,10), B(10,10), A(4,10)
      DO l=           1 ,          10 ,           1
      DO j=           1 ,          10 ,           1
        C(i+0,j+0)=C(i+0,j+0)+A(i+0,l+0)*B(l+0,j+0)
      ENDDO
      ENDDO
    END SUBROUTINE
 SUBROUTINE S(A,B,C)
    INTEGER :: Nmin=2,Niter=100
    REAL, DIMENSION(:,:), ALLOCATABLE   :: A,B,C
    DO imin=1,Nmin
     DO i=1,Niter
       CALL smm_dnn_4_10_10_1_1_2_1(A,B,C)
     ENDDO
     DO i=1,Niter
       CALL smm_dnn_4_10_10_6_4_1_1(A,B,C)
     ENDDO
     CALL foo()
    ENDDO
 END SUBROUTINE


C
C	$Id: csconstr.f,v 1.5 2008-07-27 03:10:06 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 CSCONSTR (XK,YK,ZK, CX,SX,CY,SY)
      DOUBLE PRECISION XK, YK, ZK, CX, SX, CY, SY
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   05/09/92
C
C   This subroutine constructs the elements of a 3 by 3
C orthogonal matrix R which rotates a point (XK,YK,ZK) on
C the unit sphere to the north pole, i.e.,
C
C      (XK)     (CY  0 -SY)   (1   0   0)   (XK)     (0)
C  R * (YK)  =  ( 0  1   0) * (0  CX -SX) * (YK)  =  (0)
C      (ZK)     (SY  0  CY)   (0  SX  CX)   (ZK)     (1)
C
C On input:
C
C       XK,YK,ZK = Components of a unit vector to be
C                  rotated to (0,0,1).
C
C Input parameters are not altered by this routine.
C
C On output:
C
C       CX,SX,CY,SY = Elements of R:  CX,SX define a rota-
C                     tion about the X-axis and CY,SY define
C                     a rotation about the Y-axis.
C
C Modules required by CSCONSTR:  None
C
C Intrinsic function called by CSCONSTR:  SQRT
C
C***********************************************************
C
      CY = SQRT(YK*YK + ZK*ZK)
      SY = XK
      IF (CY .NE. 0.) THEN
        CX = ZK/CY
        SX = YK/CY
      ELSE
C
C (XK,YK,ZK) lies on the X-axis.
C
        CX = 1.
        SX = 0.
      ENDIF
      RETURN
      END


!**********************************************************************************************************************************
! LICENSING
! Copyright (C) 2018  National Renewable Energy Laboratory
!
!    This file is part of OpenFAST.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!**********************************************************************************************************************************
!> This module uses Weissenger's method, also know as the Vortex Step Method (VSM), to approximate Prandtl's lifting line theory
!!  and obtain a solution for the induced angle of attack along multiple lifting surfaces.
!!  * Weissinger,  J.  1947.  The  Lift  Distribution  of  Swept-Back  Wings .  Tech.  rep.  NACA-TM-1120.  Langley  Aeronautical
!!      Lab.,  Langley  Field,  VA:  National  Advisory  Committee  for  Aeronautics.
!!  * Prandtl,  L.  1918.  Theory  of  Lifting  Surfaces .  Tech.  rep.  NACA-TR-116.  Washington,  DC:  National  Advisory  Committee
!!      for  Aeronautics.
!!
module VSM

   use NWTC_Library
   use NWTC_LAPACK
   use AirfoilInfo_Types
   use AirfoilInfo
   use VSM_Types

   implicit none

private

   type(ProgDesc), parameter  :: VSM_Ver = ProgDesc( 'VSM', '', '' )

   public :: VSM_Init
   public :: VSM_CalcOutput
   public :: VSM_CalcConstrStateResidual
   public :: VSM_UpdateStates
   public :: VSM_End

   contains
!====================================================================================================
SUBROUTINE VSM_OpenOutput( ProgName, OutRootName,  p, InitOut, ErrStat, ErrMsg )
! This subroutine initialized the output module, checking if the output parameter list (OutList)
! contains valid names, and opening the output file if there are any requested outputs
!----------------------------------------------------------------------------------------------------

      ! Passed variables

   CHARACTER(*),                  INTENT( IN    ) :: ProgName
   CHARACTER(*),                  INTENT( IN    ) :: OutRootName          ! Root name for the output file
   TYPE(VSM_ParameterType),       INTENT( INOUT ) :: p
   TYPE(VSM_InitOutPutType ),     INTENT( IN    ) :: InitOut              !
   INTEGER,                       INTENT(   OUT ) :: ErrStat              ! a non-zero value indicates an error occurred
   CHARACTER(*),                  INTENT(   OUT ) :: ErrMsg               ! Error message if ErrStat /= ErrID_None

      ! Local variables
   INTEGER                                        :: I                    ! Generic loop counter
!   INTEGER                                        :: J                    ! Generic loop counter
!   INTEGER                                        :: Indx                 ! Counts the current index into the WaveKinNd array
   CHARACTER(1024)                                :: OutFileName          ! The name of the output file  including the full path.
   CHARACTER(200)                                 :: Frmt                 ! a string to hold a format statement

   !-------------------------------------------------------------------------------------------------
   ! Initialize local variables
   !-------------------------------------------------------------------------------------------------

   ErrStat = ErrID_None
   ErrMsg  = ""

   !TODO Finish error handling

   !-------------------------------------------------------------------------------------------------
   ! Open the output file, if necessary, and write the header
   !-------------------------------------------------------------------------------------------------

   !IF ( ALLOCATED( p%OutParam ) .AND. p%NumOuts > 0 ) THEN           ! Output has been requested so let's open an output file
   IF ( p%NumOuts > 0 ) THEN
         ! Open the file for output
      OutFileName = TRIM(OutRootName)//'.VSM.out'
      CALL GetNewUnit( p%UnOutFile )

      CALL OpenFOutFile ( p%UnOutFile, OutFileName, ErrStat, ErrMsg )
      IF (ErrStat >=AbortErrLev) RETURN

         ! Write the output file header

      WRITE (p%UnOutFile,'(/,A/)', IOSTAT=ErrStat)  'These predictions were generated by '//TRIM(ProgName)//&
                      ' on '//CurDate()//' at '//CurTime()//'.'

         ! Write the names of the output parameters:

      Frmt = '(A8,'//TRIM(Int2LStr(p%NumOuts))//'(:,A,'//TRIM( p%OutSFmt )//'))'

      WRITE(p%UnOutFile,Frmt)  TRIM( 'Time' ), ( p%Delim, TRIM( InitOut%WriteOutputHdr(I) ), I=1,p%NumOuts )

     ! WRITE (p%UnOutFile,'()', IOSTAT=ErrStat)          ! write the line return

         ! Write the units of the output parameters:

      WRITE(p%UnOutFile,Frmt)  TRIM( 's'), ( p%Delim, TRIM( InitOut%WriteOutputUnt(I) ), I=1,p%NumOuts )

    !  WRITE (p%UnOutFile,'()', IOSTAT=ErrStat)          ! write the line return

   END IF   ! there are any requested outputs

   RETURN

END SUBROUTINE VSM_OpenOutput

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

!====================================================================================================
SUBROUTINE VSM_CloseOutput ( UnOutFile, ErrStat, ErrMsg )
! This function cleans up after running the HydroDyn output module. It closes the output file,
! releases memory, and resets the number of outputs requested to 0.
!----------------------------------------------------------------------------------------------------

         ! Passed variables

   INTEGER,                       INTENT( IN    ) :: UnOutFile            ! file unit for the output file
   INTEGER,                       INTENT(   OUT ) :: ErrStat              ! a non-zero value indicates an error occurred
   CHARACTER(*),                  INTENT(   OUT ) :: ErrMsg               ! Error message if ErrStat /= ErrID_None

!      ! Internal variables
   LOGICAL                               :: Err

   !-------------------------------------------------------------------------------------------------
   ! Initialize error information
   !-------------------------------------------------------------------------------------------------
   ErrStat = ErrID_None
   ErrMsg  = ""
   Err     = .FALSE.

   !-------------------------------------------------------------------------------------------------
   ! Close our output file
   !-------------------------------------------------------------------------------------------------
   CLOSE( UnOutFile, IOSTAT = ErrStat )
   IF ( ErrStat /= 0 ) Err = .TRUE.

   !-------------------------------------------------------------------------------------------------
   ! Make sure ErrStat is non-zero if an error occurred
   !-------------------------------------------------------------------------------------------------
   IF ( Err ) ErrStat = ErrID_Fatal

   RETURN

END SUBROUTINE VSM_CloseOutput
!====================================================================================================

!
!SUBROUTINE VSM_WriteOutputNames( UnOutFile, p, ErrStat, ErrMsg )
!
!   INTEGER,                      INTENT( IN    ) :: UnOutFile            ! file unit for the output file
!   TYPE(VSM_ParameterType),  INTENT( IN    ) :: p                    ! VSM module's parameter data
!   INTEGER,                      INTENT(   OUT ) :: ErrStat              ! returns a non-zero value when an error occurs
!   CHARACTER(*),                 INTENT(   OUT ) :: ErrMsg               ! Error message if ErrStat /= ErrID_None
!
!   CHARACTER(200)                         :: Frmt                        ! a string to hold a format statement
!   INTEGER                                :: I                           ! Generic loop counter
!
!   ErrStat = ErrID_None
!   ErrMsg = ""
!
!   Frmt = '(A8,'//TRIM(Int2LStr(p%NumOuts))//'(:,A,'//TRIM( p%OutSFmt )//'))'
!
!   WRITE(UnOutFile,Frmt)  'Time', ( p%Delim, TRIM( p%OutParam(I)%Name ), I=1,p%NumOuts )
!
!END SUBROUTINE VSM_WriteOutputNames
!
!!====================================================================================================
!
!
!SUBROUTINE VSM_WriteOutputUnits( UnOutFile, p, ErrStat, ErrMsg )
!
!   INTEGER,                      INTENT( IN    ) :: UnOutFile            ! file unit for the output file
!   TYPE(VSM_ParameterType),  INTENT( IN    ) :: p                    ! VSM module's parameter data
!   INTEGER,                      INTENT(   OUT ) :: ErrStat              ! returns a non-zero value when an error occurs
!   CHARACTER(*),                 INTENT(   OUT ) :: ErrMsg               ! Error message if ErrStat /= ErrID_None
!
!   CHARACTER(200)                         :: Frmt                        ! a string to hold a format statement
!   INTEGER                                :: I                           ! Generic loop counter
!
!   ErrStat = ErrID_None
!   ErrMsg = ""
!
!   Frmt = '(A8,'//TRIM(Int2LStr(p%NumOuts))//'(:,A,'//TRIM( p%OutSFmt )//'))'
!
!   WRITE(UnOutFile,Frmt)  '(sec)', ( p%Delim, TRIM( p%OutParam(I)%Units ), I=1,p%NumOuts )
!
!END SUBROUTINE VSM_WriteOutputUnits

!====================================================================================================
SUBROUTINE VSM_WriteOutputs( UnOutFile, Time, y, p, ErrStat, ErrMsg )
! This subroutine writes the data stored in WriteOutputs (and indexed in OutParam) to the file
! opened in VSM_Init()
!----------------------------------------------------------------------------------------------------

      ! Passed variables
   INTEGER,                      INTENT( IN    ) :: UnOutFile            ! file unit for the output file
   REAL(DbKi),                   INTENT( IN    ) :: Time                 ! Time for this output
   TYPE(VSM_OutputType),         INTENT( IN    ) :: y                    ! VSM module's output data
   TYPE(VSM_ParameterType),      INTENT( IN    ) :: p                    ! VSM module's parameter data
   INTEGER,                      INTENT(   OUT ) :: ErrStat              ! returns a non-zero value when an error occurs
   CHARACTER(*),                 INTENT(   OUT ) :: ErrMsg               ! Error message if ErrStat /= ErrID_None

      ! Local variables
  ! REAL(ReKi)                             :: OutData (0:p%NumOuts)       ! an output array
   INTEGER                                :: I                           ! Generic loop counter
   CHARACTER(200)                         :: Frmt                        ! a string to hold a format statement

      ! Initialize ErrStat and determine if it makes any sense to write output

   !IF ( .NOT. ALLOCATED( p%OutParam ) .OR. UnOutFile < 0 )  THEN
   IF ( UnOutFile < 0 )  THEN
      ErrStat = ErrID_Warn
      ErrMsg  = ' To write outputs for VSM there must be a valid file ID and OutParam must be allocated.'
      RETURN
   ELSE
      ErrStat = ErrID_None
      ErrMsg  = ''
   END IF

      ! Write the output parameters to the file

   Frmt = '(F8.3,'//TRIM(Int2LStr(p%NumOuts))//'(:,A,'//TRIM( p%OutFmt )//'))'
   !Frmt = '('//TRIM( p%OutFmt )//','//TRIM(Int2LStr(p%NumOuts))//'(:,A,'//TRIM( p%OutFmt )//'))'

   WRITE(UnOutFile,Frmt)  Time, ( p%Delim, y%WriteOutput(I), I=1,p%NumOuts )

   RETURN

END SUBROUTINE VSM_WriteOutputs

subroutine VSM_Compute_Influence(CtrlPtMod, KinVisc,  numVolElem, numElem, inPtA, inPtB, U_Inf_v, x_hat, y_hat, chord, noInflow, Phi_v, Phi_AB2D_v, errStat, errMsg)

   integer(IntKi),          intent(in   ) :: CtrlPtMod
   real(ReKi),              intent(in   ) :: KinVisc
   integer(IntKi),          intent(in   ) :: numVolElem
   integer(IntKi),          intent(in   ) :: numElem
   real(ReKi),              intent(in   ) :: inPtA(:,:), inPtB(:,:), U_Inf_v(:,:), x_hat(:,:), y_hat(:,:)
   real(ReKi),              intent(in   ) :: chord(:)
   logical,                 intent(  out) :: noInflow
   real(ReKi),              intent(inout) :: Phi_v(3,numElem, numElem), Phi_AB2D_v(3,numElem)
   integer(IntKi),          intent(  out) :: errStat    !< Error status
   character(*),            intent(  out) :: errMsg     !< Error message

   integer(IntKi)   :: i,j
   real(ReKi)  :: PtC(3,numElem), PtP(3,numElem), PtA(3,numElem), PtB(3,numElem)
   real(ReKi)  :: r0, r0_v(3), zeta_hat(3), tmp_v(3), tmp, U_Inf, U_InfTotal, e2, r0_hat(3)
   real(ReKi)  :: r1_v(3), r2_v(3), r3_v(3), r1_hat(3), r2_hat(3), r1_primeprime_v(3), r2_primeprime_v(3)
   real(ReKi)  :: r1p_v(3), r2p_v(3), r1_prime_v(3), r2_prime_v(3), Phi_Ainf_v(3), Phi_Binf_v(3), eta11_v(3), eta12_v(3), eta11_hat(3), eta12_hat(3), eta2_v(3)
   real(ReKi)  :: r1p_prime_v(3), r2p_prime_v(3), cp_v(3), tmp1cZeta_v(3), tmp2cZeta_v(3), tmp1c0_v(3),tmp1c2_v(3)
   real(ReKi)  :: r1_primeprime_hat(3), r2_primeprime_hat(3), Phi_AB_v(3), tmp2D_v(3), tmp1_v(3), tmp2_v(3), tmpAB_v(3)
   real(ReKi)  :: alpha0, r1, r2, Factor2D, e11,  e12,  r1_prime, r2_prime,  Factor1, Factor2, FactorAB, r1p, r2p
   real(ReKi)  :: tmp1cZeta, tmp2cZeta, tmp1c0,tmp1c2, U_Inf_hat(3), U_Inf_ave(3)
   integer(IntKi)                           :: errStat2
   logical     :: EnabUABCor
   character(ErrMsgLen)                     :: errMsg2
   character(*), parameter                  :: routineName = 'VSM_Compute'

   Phi_v = 0.0_ReKi
   Phi_AB2D_v = 0.0_ReKi
   U_InfTotal = 0.0_ReKi
   noInflow = .false.

   ! We are now using an average of all the inflow directions to determine a single direction for use across all VSM elements.
   U_Inf_ave  = 0.0_ReKi
   do i = 1+numVolElem, numElem
      U_Inf = TwoNorm(U_Inf_v(:,i))
      if ( .not. EqualRealNos(U_Inf, 0.0_ReKi) ) then
         U_Inf_hat = U_Inf_v(:,i) / U_Inf
         U_Inf_ave = U_Inf_ave + U_Inf_hat
      end if
   end do

   U_Inf = TwoNorm(U_Inf_ave)
   if (.not. EqualRealNos(U_Inf, 0.0_ReKi) ) U_Inf_ave = U_Inf_ave / U_Inf

   do i = 1+numVolElem, numElem

      PtC(:,i) = (inPtA(:,i) + inPtB(:,i)) / 2.0_ReKi

      U_Inf = TwoNorm(U_Inf_v(:,i))
      U_InfTotal = U_InfTotal + U_Inf

      if ( EqualRealNos(U_Inf, 0.0_ReKi) ) then
         U_Inf_hat = U_Inf_v(:,i)
      else
         U_Inf_hat = U_Inf_v(:,i) / TwoNorm(U_Inf_v(:,i))
      end if

      if (CtrlPtMod == 1) then
         PtP(:,i) = PtC(:,i) + 0.5*chord(i)*y_hat(:,i)
      else
            ! Along the freestream direction
            ! Rotate 3/4 chord onto the average free stream vector, using C as stationary point
         PtP(:,i) = PtC(:,i) + 0.5*chord(i)*U_Inf_ave
      end if

      r0_hat = (inPtB(:,i) - inPtA(:,i)) / TwoNorm(inPtB(:,i) - inPtA(:,i))

      tmp2_v = cross_product(U_Inf_hat,r0_hat)
      if ( dot_product(x_hat(:,i),tmp2_v) < 0 ) then  ! x_hat is normal to the chord
         !errMsg2 = 'Element is not properly oriented relative to free stream inflow vector'
         !errStat2 = ErrID_Fatal
         !call SetErrStat(errStat2,errMsg2,errStat,errMsg,RoutineName)
         !return
         !write(*,*) "Needed to reorder element #"//trim(num2lstr(i))
         PtA(:,i) = inPtB(:,i)
         PtB(:,i) = inPtA(:,i)
      else
         PtA(:,i) = inPtA(:,i)
         PtB(:,i) = inPtB(:,i)
      end if

   end do

   if ( EqualRealNos(U_InfTotal, 0.0_ReKi) ) then

      ! Degenerate case, no inflow anywhere
      noInflow = .true.
      return

   end if

   do j = 1+numVolElem, numElem

      alpha0 = 1.25643 ! Oseen parameter

   ! Calculate U_AB2D  only for element j
      r0_v  = PtB(:,j) - PtA(:,j)
      r0    = TwoNorm(r0_v)
      r3_v  = PtP(:,j) - PtC(:,j)
      tmp2D_v  = cross_product(r0_v,r3_v)
      Factor2D = dot_product(tmp2D_v,tmp2D_v)
      Phi_AB2D_v(:,j) = 0.0_ReKi
      U_Inf = TwoNorm(U_Inf_v(:,j))
      if ( (.not. EqualRealNos(Factor2D,0.0_ReKi) ) .and. (.not. EqualRealNos(U_Inf,0.0_ReKi) ) ) then

         !! error
         !errMsg2 = 'Cross products of r0 and r3 produce a zero length vector which creates a divide by zero error'
         !errStat2 = ErrID_Fatal
         !call SetErrStat(errStat2,errMsg2,errStat,errMsg,RoutineName)
         !return

         Phi_AB2D_v(:,j) = ( r0 / (2.0*Pi*Factor2D))*tmp2D_v
      end if

      do i = 1+numVolElem, numElem
         r0_v  = PtB(:,i) - PtA(:,i)
         r0    = TwoNorm(r0_v)
         r1_v  = PtP(:,j) - PtA(:,i)
         r2_v  = PtP(:,j) - PtB(:,i)
         r3_v  = PtP(:,j) - PtC(:,i)
         tmp2D_v  = cross_product(r0_v,r3_v)
         Factor2D = dot_product(tmp2D_v,tmp2D_v)
         r1   = TwoNorm(r1_v)
         r2   = TwoNorm(r2_v)
         U_Inf = TwoNorm(U_Inf_v(:,i))
         ! TODO: Check that r1 > 0 and r2>0

         if ( EqualRealNos(r1,0.0_ReKi) .or. EqualRealNos(r2,0.0_ReKi) .or. EqualRealNos(U_Inf,0.0_ReKi) .or. EqualRealNos(Factor2D,0.0_ReKi)) then
            Phi_v(:,i,j) = 0.0_ReKi
         else

            r1_hat = r1_v / r1
            r2_hat = r2_v / r2

               ! TODO: Compute zeta_hat per element when we determine PtP for each element.
            tmp_v = PtP(:,i) - PtC(:,i)
            tmp   = TwoNorm(tmp_v)
            if ( EqualRealNos(tmp,0.0_ReKi) ) then
               !errMsg2 = 'zeta is a zero length vector which creates a divide by zero error'
               !errStat2 = ErrID_Fatal
               !call SetErrStat(errStat2,errMsg2,errStat,errMsg,RoutineName)
               !return
               ! This implies chord length is zero for this element
               Phi_Ainf_v = 0.0_ReKi
            else

               zeta_hat = tmp_v / tmp
               e2 = 0.05*r0

         ! Calculate U_Ainf(i,j)

               r1p_v      = dot_product(r1_v,zeta_hat)*zeta_hat
               r1p        = TwoNorm(r1p_v)
               e11        = sqrt(4*alpha0*kinvisc*r1p/U_Inf)

               tmp1cZeta_v = cross_product(r1_v,zeta_hat)
               tmp1cZeta = TwoNorm(tmp1cZeta_v)

               if ( tmp1cZeta > e11 ) then
                  Factor1   = tmp1cZeta*tmp1cZeta
                  Phi_Ainf_v = (( 1.0_ReKi + dot_product(r1_v,zeta_hat)/r1 ) / (4.0_ReKi*Pi*Factor1) ) * tmp1cZeta_v
               else if ( EqualRealNos(tmp1cZeta, 0.0_ReKi) ) then
                  Phi_Ainf_v = 0.0_ReKi
               else
                  eta11_v    = r1_hat - zeta_hat
                  eta11_hat  = eta11_v / TwoNorm(eta11_v)
                  r1_prime_v = r1p_v + e11*eta11_hat
                  r1_prime   = TwoNorm(r1_prime_v)
                  if ( EqualRealNos(r1_prime,0.0_ReKi) ) then
                     !errMsg2 = 'r1_prime is equal to zero which creates a divide by zero error'
                     !errStat2 = ErrID_Fatal
                     !call SetErrStat(errStat2,errMsg2,errStat,errMsg,RoutineName)
                     !return
                     Phi_Ainf_v = 0.0_ReKi
                  else

                     tmp1_v = cross_product(r1_prime_v,zeta_hat) / (4.0_ReKi*Pi)
                     Factor1 = dot_product(tmp1_v,tmp1_v)
                     if ( EqualRealNos(Factor1,0.0_ReKi) ) then
                        !errMsg2 = 'Cross products of r1_prime and zeta produce a zero length vector which creates a divide by zero error'
                        !errStat2 = ErrID_Fatal
                        !call SetErrStat(errStat2,errMsg2,errStat,errMsg,RoutineName)
                        !return
                        Phi_Ainf_v = 0.0_ReKi
                     else

                        Phi_Ainf_v = ( ( 1.0_ReKi + dot_product(r1_prime_v,zeta_hat)/r1_prime ) / (Factor1) ) * tmp1_v
                        Phi_Ainf_v = Phi_Ainf_v * tmp1cZeta / e11
                     end if
                  end if
               end if
            end if

         ! Calculate U_Binf(j,i)
            r2p_v      = dot_product(r2_v,zeta_hat)*zeta_hat
            r2p        = TwoNorm(r2p_v)
            e12        = sqrt(4*alpha0*kinvisc*r2p/U_Inf)
            e12        = sqrt(4*alpha0*kinvisc*r2/U_Inf)

            tmp2cZeta_v = cross_product(r2_v,zeta_hat)
            tmp2cZeta = TwoNorm(tmp2cZeta_v)

            if ( tmp2cZeta > e12 ) then
               Factor2   = tmp2cZeta*tmp2cZeta
               Phi_Binf_v = ( -( 1.0_ReKi + dot_product(r2_v,zeta_hat)/r2 ) / (4.0_ReKi*Pi*Factor2) ) * tmp2cZeta_v
            else if ( EqualRealNos(tmp2cZeta, 0.0_ReKi) ) then
               Phi_Binf_v = 0.0_ReKi
            else
               eta12_v    = r2_hat - zeta_hat
               eta12_hat  = eta12_v / TwoNorm(eta12_v)
               r2_prime_v = r2p_v + e12*eta12_hat
               r2_prime   = TwoNorm(r2_prime_v)
               if ( EqualRealNos(r2_prime,0.0_ReKi) ) then
                  !errMsg2 = 'r2_prime is equal to zero which creates a divide by zero error'
                  !errStat2 = ErrID_Fatal
                  !call SetErrStat(errStat2,errMsg2,errStat,errMsg,RoutineName)
                  !return
                  Phi_Binf_v = 0.0_ReKi
               else

                  tmp2_v = cross_product(r2_prime_v,zeta_hat) / (4.0_ReKi*Pi)
                  Factor2 = dot_product(tmp2_v,tmp2_v)
                  if ( EqualRealNos(Factor2,0.0_ReKi) ) then
                     !errMsg2 = 'Cross products of r2_prime_v and zeta produce a zero length vector which creates a divide by zero error'
                     !errStat2 = ErrID_Fatal
                     !call SetErrStat(errStat2,errMsg2,errStat,errMsg,RoutineName)
                     !return
                     Phi_Binf_v = 0.0_ReKi
                  else
                     Phi_Binf_v = ( -( 1.0_ReKi + dot_product(r2_prime_v,zeta_hat)/r2_prime ) / (Factor2) ) * tmp2_v
                     Phi_Binf_v = Phi_Binf_v * tmp2cZeta / e12
                  end if
               end if
            end if

         ! Calculate U_AB

            tmp1c0_v = cross_product(r1_v,r0_v)
            tmp1c0   = TwoNorm(tmp1c0_v)

            !Check if the vortex core correction will be enabled for the bound vortex
            EnabUABCor = .FALSE.
            IF ((TwoNorm(r2_v) < e2) .OR. (TwoNorm(r1_v) < e2)) THEN
               EnabUABCor = .TRUE.
            ELSEIF ( (dot_product(r1_v,r0_v) > 0 ) .AND. (dot_product(r2_v,r0_v) < 0 ) .AND. ( TwoNorm(cross_product( r1_v, r0_v ))/r0 < e2 ) ) THEN
               EnabUABCor = .TRUE.
            ENDIF

            if ( EnabUABCor .eqv. .FALSE. ) then
               tmp1c2_v = cross_product(r1_v,r2_v)
               tmp1c2   = dot_product(tmp1c2_v,tmp1c2_v)
               Phi_AB_v = ( (dot_product( r0_v, (r1_hat - r2_hat) ) ) / (4.0*Pi*tmp1c2) ) * tmp1c2_v
            else if ( EqualRealNos(tmp1c0, 0.0_ReKi) ) then
               Phi_AB_v = 0.0_ReKi
            else
               r0_hat          = r0_v/TwoNorm(r0_v)
               r1p_prime_v     = dot_product(r1_v,r0_hat)*r0_hat
               cp_v            = cross_product(r1_v,r0_v)
               tmp             = TwoNorm(cp_v)
               if ( EqualRealNos(tmp,0.0_ReKi) ) then
                  errMsg2 = 'Cross products of r1 and r0 produce a zero length vector which creates a divide by zero error'
                  errStat2 = ErrID_Fatal
                  call SetErrStat(errStat2,errMsg2,errStat,errMsg,RoutineName)
                  return
               end if
               eta2_v         =  cp_v / tmp
               r1_primeprime_v = r1p_prime_v + e2*eta2_v
               tmp             = TwoNorm(r1_primeprime_v)
               if (EqualRealNos(tmp,0.0_ReKi) ) then
                  errMsg2 = 'r1_primeprime is equal to zero which creates a divide by zero error'
                  errStat2 = ErrID_Fatal
                  call SetErrStat(errStat2,errMsg2,errStat,errMsg,RoutineName)
                  return
               end if
               r1_primeprime_hat = r1_primeprime_v / tmp

               r2p_prime_v     = dot_product(r2_v,r0_hat)*r0_hat

               r2_primeprime_v = r2p_prime_v + e2*eta2_v
               tmp = TwoNorm(r2_primeprime_v)
               if (EqualRealNos(tmp,0.0_ReKi) ) then
                  errMsg2 = 'r2_primeprime is equal to zero which creates a divide by zero error'
                  errStat2 = ErrID_Fatal
                  call SetErrStat(errStat2,errMsg2,errStat,errMsg,RoutineName)
                  return
               end if
               r2_primeprime_hat = r2_primeprime_v / tmp

               tmpAB_v = cross_product(r1_primeprime_v,r2_primeprime_v)
               FactorAB = dot_product(tmpAB_v,tmpAB_v)

               if ( EqualRealNos(4.0_ReKi*Pi*FactorAB,0.0_ReKi) ) then

                  !errMsg2 = 'Cross products of r1_primeprime and r2_primeprime produce a zero length vector which creates a divide by zero error'
                  !errStat2 = ErrID_Fatal
                  !call SetErrStat(errStat2,errMsg2,errStat,errMsg,RoutineName)
                  !return
                  Phi_AB_v = 0.0_ReKi
               else
                  Phi_AB_v = ( dot_product(r0_v, r1_primeprime_hat - r2_primeprime_hat  ) / (4.0*Pi*FactorAB) ) * tmpAB_v
                  Phi_AB_v = tmp1c0 * Phi_AB_v / (e2*r0)
               end if

            end if

            Phi_v(:,i,j) = Phi_AB_v + Phi_Ainf_v + Phi_Binf_v

         end if
      end do !  i

   end do ! j

end subroutine VSM_Compute_Influence

subroutine VSM_Compute( AirDens, numVolElem, numElem, elemLens, U_Inf_v, x_hat, y_hat, p_AFI, AFIDs, deltaf, chord, Gammas, Phi_v, Phi_AB2D_v, U_Ind_v, alpha, Fx, Fy, Mz, Cl, Cd, Cm, residual, errStat, errMsg)

   real(ReKi),              intent(in   ) :: AirDens
   integer(IntKi),          intent(in   ) :: numVolElem
   integer(IntKi),          intent(in   ) :: numElem
   real(ReKi),              intent(in   ) :: elemLens(numElem), U_Inf_v(3,numElem), x_hat(3,numElem), y_hat(3,numElem)
   type(AFI_ParameterType), intent(in   ) :: p_AFI(:)
   integer(IntKi),          intent(in   ) :: AFIDs(numElem)
   real(ReKi),              intent(in   ) :: deltaf(numElem)
   real(ReKi),              intent(in   ) :: chord(numElem)
   real(ReKi),              intent(in   ) :: Gammas(numElem)
   real(ReKi),              intent(in   ) :: Phi_v(3,numElem,numElem),Phi_AB2D_v(3,numElem)
   real(ReKi),              intent(  out) :: U_Ind_v(3,numElem), alpha(numElem), Fx(numElem), Fy(numElem), Mz(numElem), Cl(numElem), Cd(numElem), Cm(numElem), residual(numElem)
   integer(IntKi),          intent(  out) :: errStat    !< Error status
   character(*),            intent(  out) :: errMsg     !< Error message

   integer(IntKi)          :: i,j
   real(ReKi)              :: U_rel_v(3)
   real(ReKi)              :: Ux, Uy, U_2D, U_Infx, U_Infy, U_Inf_2D , Factor, elemLen, diff(3)
   type(AFI_OutputType)    :: AFI_Interp
   character(*), parameter :: routineName = 'VSM_Compute'

   do j = 1, numElem

      U_ind_v(:,j) = 0.0_ReKi  ! Volume elements will not have induction

      if (j > numVolElem) then

         do i = 1+numVolElem, numElem
            U_ind_v(:,j) = U_ind_v(:,j) + Gammas(i-numVolElem)*Phi_v(:,i,j)
         end do

         U_ind_v(:,j)  = U_ind_v(:,j) - Gammas(j-numVolElem)*Phi_AB2D_v(:,j)

      end if

      U_rel_v = U_Inf_v(:,j) + U_ind_v(:,j)

      Ux      = dot_product( U_rel_v, x_hat(:,j))
      Uy      = dot_product( U_rel_v, y_hat(:,j))
      alpha(j)   = atan2( Ux, Uy )  ! atan2 ( vert, horiz )

      call AFI_ComputeAirfoilCoefs( alpha(j), 0.0_ReKi, deltaf(j), p_AFI(AFIDs(j)), &
                         AFI_Interp, errStat, errMsg )
      Cl(j) = AFI_Interp%Cl
      Cd(j) = AFI_Interp%Cd  +0.075 ! RRD: brutally adding a fudge factor everywhere; this should be 0.075*Swing=Sum(fudge*c*dy)==>fudge=0.075*S/Stot
      Cm(j) = AFI_Interp%Cm

      U_2D = Ux**2+Uy**2
      U_Infx =  dot_product( U_Inf_v(:,j), x_hat(:,j))
      U_Infy  = dot_product( U_Inf_v(:,j), y_hat(:,j))
      U_Inf_2D = sqrt(U_Infx**2 + U_Infy**2)

      Factor = 0.5*AirDens*U_2D*elemLens(j)*chord(j)

         ! These are in the local airfoil frame
      Fx(j) = Factor*(  Cl(j)*cos(alpha(j)) + Cd(j)*sin(alpha(j)) ) ! N
      Fy(j) = Factor*( -Cl(j)*sin(alpha(j)) + Cd(j)*cos(alpha(j)) ) ! N
      Mz(j) = Factor*chord(j)*Cm(j)                                 ! Nm

         ! Do not incude the drag elements in the residual calculations
      if (j > numVolElem) then
         residual(j-numVolElem) = U_Inf_2D*Gammas(j-numVolElem) - 0.5*U_2D*chord(j)*Cl(j)
      end if

   end do ! j

end subroutine VSM_Compute

!----------------------------------------------------------------------------------------------------------------------------------
!> This subroutine sets up the data structures and initializes AirfoilInfo to get the necessary AFI parameters.
subroutine Init_AFIparams( InitInp, p_AFI, UnEc, errStat, errMsg )

      ! Passed variables
   type(VSM_InitInputType),             intent(inout)   :: InitInp    !< Initialization input data for VSM (intent(out) only because of the call to MOVE_ALLOC)
   type(AFI_ParameterType), allocatable, intent(  out)   :: p_AFI(:)   !< parameters returned from the AFI (airfoil info) module
   integer(IntKi),                       intent(in   )   :: UnEc       !< I/O unit for echo file. If > 0, file is open for writing.
   integer(IntKi),                       intent(  out)   :: errStat    !< Error status
   character(*),                         intent(  out)   :: errMsg     !< Error message

      ! local variables
   type(AFI_InitInputType)                  :: AFI_InitInputs     ! initialization data for the AFI routines
   integer(IntKi)                           :: File               ! loop counter for airfoil files
   integer(IntKi)                           :: errStat2
   character(ErrMsgLen)                     :: errMsg2
   character(*), parameter                  :: RoutineName = 'Init_AFIparams'

   errStat = ErrID_None
   errMsg  = ""

   allocate(p_AFI( InitInp%NumAFfiles), STAT = ErrStat2)
      if ( ErrStat2 /= 0 ) then
         ErrMsg2 = 'Error allocating p_AFI'
         ErrStat2 = ErrID_Fatal
         call SetErrStat(ErrStat2,ErrMsg2,errStat,errMsg,RoutineName)
         return
      end if

      ! Setup Airfoil InitInput data structure:

   AFI_InitInputs%InCol_Alfa  = InitInp%InCol_Alfa
   AFI_InitInputs%InCol_Cl    = InitInp%InCol_Cl
   AFI_InitInputs%InCol_Cd    = InitInp%InCol_Cd
   AFI_InitInputs%InCol_Cm    = InitInp%InCol_Cm
   AFI_InitInputs%InCol_Cpmin = 0
   !AFI_InitInputs%UA_Model	   =  0
   AFI_InitInputs%AFTabMod    =  InitInp%AFTabMod

   do File = 1, InitInp%NumAFfiles

      ! Call AFI_Init to read in and process an airfoil file.
      ! This includes creating the spline coefficients to be used for interpolation.

      AFI_InitInputs%FileName = InitInp%AFNames(File)

      call AFI_Init ( AFI_InitInputs, p_AFI(File), ErrStat2, ErrMsg2, UnEc )
         call SetErrStat(ErrStat2,'Problem with airfoil file #'//trim(num2lstr(File))//': '//trim(ErrMsg2), errStat, errMsg, RoutineName)

      if (errStat >= AbortErrLev) return

   end do

   call AFI_DestroyInitInput( AFI_InitInputs, ErrStat2, ErrMsg2 )
      call SetErrStat(ErrStat2,ErrMsg2, errStat, errMsg, RoutineName)
      if (errStat >= AbortErrLev) return

end subroutine Init_AFIparams

subroutine VSM_Solve( t, n, u, p, z, OtherState, m, errStat, errMsg )
! Loose coupling routine for solving for constraint states
!
! NOTE:  This is not framework interface.
!..................................................................................................................................

   real(DbKi),                         intent(in   ) :: t          ! Current simulation time in seconds
   integer(IntKi),                     intent(in   ) :: n          ! Current simulation time step n = 0,1,...
   type(VSM_InputType),                intent(in   ) :: u          ! Input at t+ Interval
   type(VSM_ParameterType),            intent(in   ) :: p          ! Parameters
   type(VSM_ConstraintStateType),      intent(inout) :: z          ! Input: Constraint states at t;
                                                                    !   Output: Constraint states at t + Interval
   type(VSM_OtherStateType),           intent(in   ) :: OtherState ! Other States

   type(VSM_MiscVarType),              intent(inout) :: m          ! Misc/optimization variables
   integer(IntKi),                     intent(  out) :: errStat    ! Error status of the operation
   character(*),                       intent(  out) :: errMsg     ! Error message if ErrStat /= ErrID_None

   integer(IntKi)   :: i, k
   real(ReKi)       :: dz
   type(VSM_ConstraintStateType)  :: z_tmp, zPerturb, z_residual, z_resPerturb
   real(ReKi)       :: deltazMag
   real(ReKi), allocatable      :: deltaz(:)
   real(ReKi), allocatable      :: dZdz(:,:), dZdz_factor(:,:)
   integer(IntKi), allocatable  :: dZdz_pivot(:)

   errStat = ErrID_None
   errMsg  = ''

   if ( p%LiftMod == 1 ) return ! no real states: z%Gammas were set to zero at initialization

   call AllocAry(dZdz, p%numGammas,p%numGammas, 'dZdz', errStat, errMsg)
   call AllocAry(dZdz_factor, p%numGammas,p%numGammas, 'dZdz_factor', errStat, errMsg)
   call AllocAry(deltaz, p%numGammas, 'deltaz', errStat, errMsg)
   call AllocAry(dZdz_pivot, p%numGammas, 'dZdz_pivot', errStat, errMsg)
   if (  OtherState%NoStates ) z%Gammas = 0.6

   call VSM_CopyConstrState( z, zPerturb, 0, errStat, errMsg )
   call VSM_CopyConstrState( z, z_residual, 0, errStat, errMsg )
   call VSM_CopyConstrState( z, z_resPerturb, 0, errStat, errMsg )

   k  = 0
   dz = p%VSMPerturb

   call VSM_Compute_Influence(p%CtrlPtMod, p%KinVisc, p%NumVolElem, p%numElem, u%PtA, u%PtB, u%U_Inf_v, u%x_hat, u%y_hat, p%Chords, m%NoInflow, m%Phi_v, m%Phi_AB2D_v, errStat, errMsg)
      if ( errStat >= AbortErrLev ) return

   if ( m%NoInflow ) then
      z%Gammas = 0.0_ReKi
      return
   end if

      ! Obtain copy of states in case the solution does not converge, that way the previous solution will be used for the current time step.
   call VSM_CopyConstrState( z, z_tmp, 0, errStat, errMsg )

   do
      if ( k == p%VSMMaxIter ) then
         ErrStat = ErrID_Warn
         errMsg  = 'VSM_UpdateStates: Maximum number of Newton iterations of '//trim(num2lstr(p%VSMMaxIter))//' has been reached before convergence.  The residual, '//trim(num2lstr(deltazMag))//', is larger than the target threshold of, '//trim(num2lstr(p%VSMToler))//'. Using solution from previous timestep.'
         call WrScr(errMsg)
         call VSM_CopyConstrState( z_tmp, z, 0, errStat, errMsg )
         exit
      end if

         ! Compute Z(z,u,t) for k
      call VSM_CalcConstrStateResidual( t, u, p, z, m, z_residual, errStat, errMsg )
         if ( errStat >= AbortErrLev ) return

         ! Compute the gradient matrix dZdz(n,n) when perturbing z
      zPerturb%Gammas = z%Gammas
      do i = 1, p%NumGammas
         zPerturb%Gammas(i) = z%Gammas(i) + dz
         call VSM_CalcConstrStateResidual( t, u, p, zPerturb, m, z_resPerturb, errStat, errMsg )
            if ( errStat >= AbortErrLev ) return
         dZdz(:,i) = (z_resPerturb%Gammas(:) - z_residual%Gammas(:)) / dz
         zPerturb%Gammas(i) = z%Gammas(i)
      end do

         ! Solve the equations Ax = b

      dZdz_factor = dZdz
      deltaz      = -z_residual%Gammas

      call LAPACK_getrf( M=p%NumGammas, N=p%NumGammas, A=dZdz_factor, IPIV=dZdz_pivot, ErrStat=errStat, ErrMsg=errMsg )
         if ( errStat >= AbortErrLev ) return

      call LAPACK_getrs( TRANS='N',N=p%NumGammas, A=dZdz_factor,IPIV=dZdz_pivot, B=deltaz, ErrStat=ErrStat, ErrMsg=ErrMsg)
         if ( ErrStat >= AbortErrLev ) return

      deltazMag = TwoNorm(deltaz)
      if ( deltazMag < p%VSMToler ) exit

      z%Gammas = z%Gammas + deltaz

      k = k+1

   end do

end subroutine VSM_Solve

!==============================================================================
! Framework Routines                                                          !
!==============================================================================

!----------------------------------------------------------------------------------------------------------------------------------
subroutine VSM_UpdateStates( t, n, u, p, z, OtherState, m, errStat, errMsg )
! Loose coupling routine for solving for constraint states, integrating continuous states, and updating discrete states
! Continuous, constraint, discrete, and other states are updated for t + Interval
!
! NOTE:  This is a non-standard framework interface.
!..................................................................................................................................

   real(DbKi),                         intent(in   ) :: t          ! Current simulation time in seconds
   integer(IntKi),                     intent(in   ) :: n          ! Current simulation time step n = 0,1,...
   type(VSM_InputType),                intent(in   ) :: u          ! Input at t+ Interval
   type(VSM_ParameterType),            intent(in   ) :: p          ! Parameters
   type(VSM_ConstraintStateType),      intent(inout) :: z          ! Input: Constraint states at t;
                                                                    !   Output: Constraint states at t + Interval
   type(VSM_OtherStateType),           intent(inout) :: OtherState !< Other States
   type(VSM_MiscVarType),              intent(inout) :: m          ! Misc/optimization variables
   integer(IntKi),                     intent(  out) :: errStat    ! Error status of the operation
   character(*),                       intent(  out) :: errMsg     ! Error message if ErrStat /= ErrID_None

   errStat = ErrID_None
   errMsg  = ''

   call VSM_Solve( t, n, u, p, z, OtherState, m, errStat, errMsg )

   if (p%LiftMod == 2) OtherState%NoStates = .false.

end subroutine VSM_UpdateStates

!----------------------------------------------------------------------------------------------------------------------------------
subroutine VSM_CalcConstrStateResidual( Time, u, p, z, m, z_residual, errStat, errMsg )
! Tight coupling routine for solving for the residual of the constraint state equations
!..................................................................................................................................

   real(DbKi),                    intent(in   )  :: Time        ! Current simulation time in seconds
   type(VSM_InputType),           intent(in   )  :: u           ! Inputs at Time
   type(VSM_ParameterType),       intent(in   )  :: p           ! Parameters
   type(VSM_ConstraintStateType), intent(in   )  :: z           ! Constraint states at Time (possibly a guess)
   type(VSM_MiscVarType),         intent(inout)  :: m           !< Misc Vars
   type(VSM_ConstraintStateType), intent(inout)  :: z_residual  ! Residual of the constraint state equations using
                                                                 !     the input values described above
   integer(IntKi),                intent(  out)  :: errStat     ! Error status of the operation
   character(*),                  intent(  out)  :: errMsg      ! Error message if errStat /= ErrID_None

      !# set epsilon
   !REAL(ReKi), PARAMETER     ::epsilon = 1e-6

      ! Local variables

   character(*), parameter                        :: RoutineName = 'VSM_CalcConstrStateResidual'
   real(ReKi)                                     :: U_Ind_v(3,p%NumElem), alpha(p%NumElem), Fx(p%NumElem),Fy(p%NumElem),Mz(p%NumElem), Cl(p%NumElem),Cd(p%NumElem),Cm(p%NumElem)

   errStat = ErrID_None
   errMsg  = ""
   if ( p%LiftMod == 1 ) then
      z_residual%Gammas = 0.0_ReKi
   else
      call VSM_Compute( p%AirDens, p%NumVolElem, p%numElem, p%ElemLens, u%U_Inf_v, u%x_hat, u%y_hat, p%AFInfo, p%AFIDs, u%deltaf, p%Chords, z%Gammas, m%Phi_v, m%Phi_AB2D_v, U_Ind_v, alpha, Fx, Fy, Mz, Cl, Cd, Cm, z_residual%Gammas, errStat, errMsg)
   end if

end subroutine VSM_CalcConstrStateResidual

!==============================================================================
subroutine VSM_Init( InitInp, u, p, z, Otherstate, m, y, interval, InitOut, errStat, errMsg )
! This routine is called at the start of the simulation to perform initialization steps.
! The parameters are set here and not changed during the simulation.
! The initial states and initial guess for the input are defined.
!..............................................................................

   type(VSM_InitInputType),       intent(inout)  :: InitInp     !< Input data for initialization routine, needs to be inout because there is a copy of some data in InitInp in VSM_SetParameters()
   type(VSM_InputType),           intent(in   )  :: u           !< An initial guess for the input; input mesh must be defined
   type(VSM_ParameterType),       intent(  out)  :: p           !< Parameters
   type(VSM_ConstraintStateType), intent(inout)  :: z           !< Input: Constraint states at t;
                                                                    !<  Output: Constraint states at t + Interval
   type(VSM_OtherStateType),      intent(inout)  :: OtherState  !< Other States
   type(VSM_MiscVarType),         intent(inout)  :: m           !< Misc Vars
   type(VSM_OutputType),          intent(  out)  :: y           !< Initial system outputs (outputs are not calculated;
                                                                   !<   only the output mesh is initialized)
   real(DbKi),                    intent(inout)  :: interval    !< Coupling interval in seconds:
                                                                   !<   Input is the suggested time from the glue code;
                                                                   !<   Output is the actual coupling interval that will be used
                                                                   !<   by the glue code.
   type(VSM_InitOutputType),      intent(  out)  :: InitOut     !< Output for initialization routine
   integer(IntKi),                intent(  out)  :: errStat     !< Error status of the operation
   character(*),                  intent(  out)  :: errMsg      !< Error message if errStat /= ErrID_None

      ! Local variables
   character(ErrMsgLen)                         :: errMsg2     ! temporary Error message if errStat /= ErrID_None
   integer(IntKi)                               :: errStat2    ! temporary Error status of the operation
   character(*), parameter                      :: routineName = 'VSM_Init'
   integer(IntKi)                               :: j,count
   integer(IntKi)                               :: UnEc

      ! Initialize variables for this routine
   errStat = ErrID_None
   errMsg  = ""
   UnEc    = -1

      ! Initialize the NWTC Subroutine Library
   call NWTC_Init( EchoLibVer=.FALSE. )

      ! Display the module information
   call DispNVD( VSM_Ver )

      ! Set parameters based on initialization inputs
   p%AirDens       = InitInp%AirDens
   p%KinVisc       = InitInp%KinVisc
   p%CtrlPtMod     = InitInp%CtrlPtMod
   p%LiftMod       = InitInp%LiftMod
   p%VSMMaxIter    = InitInp%VSMMaxIter
   p%VSMPerturb    = InitInp%VSMPerturb
   p%VSMToler      = InitInp%VSMToler
   p%AFTabMod      = InitInp%AFTabMod
   p%NumVolElem    = InitInp%NumVolElem
   p%NumElem       = InitInp%NumElem         ! This includes the Volume elements (NumVolElem)
   p%NumGammas     = p%NumElem - p%NumVolElem
   p%ElemLens      = InitInp%ElemLens
      ! Allocate arrays
   call AllocAry( p%Chords, p%NumElem, 'p%Chords', errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( p%AFIDs , p%NumElem, 'p%AFIDs' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )

   call AllocAry( m%PtP , 3, p%NumElem, 'm%PtP' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( m%PtC , 3, p%NumElem, 'm%PtC' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( m%Phi_AB2D_v , 3, p%NumElem, 'm%Phi_AB2D_v' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   m%Phi_AB2D_v=0.0_ReKi
   call AllocAry( m%Phi_v , 3, p%NumElem, p%NumElem, 'm%Phi_v' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   m%Phi_v = 0.0_ReKi
   call AllocAry( u%PtA , 3, p%NumElem, 'u%PtA' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( u%PtB , 3, p%NumElem, 'u%PtB' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )

   call AllocAry( u%x_hat  , 3, p%NumElem, 'u%x_hat  ' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( u%y_hat  , 3, p%NumElem, 'u%y_hat  ' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( u%z_hat  , 3, p%NumElem, 'u%z_hat  ' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( u%U_Inf_v, 3, p%NumElem, 'u%U_Inf_v' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( u%Deltaf ,    p%NumElem, 'u%Deltaf ' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )

   call AllocAry( y%Loads , 6, p%NumElem, 'y%Loads ' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( y%AoA , p%NumElem, 'y%AoA ' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( y%Cl , p%NumElem, 'y%Cl ' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( y%Vind , 3, p%NumElem, 'y%Vind ' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( y%Cd , p%NumElem, 'y%Cd ' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( y%Cm , p%NumElem, 'y%Cm ' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )

      ! The volume elements do not have states
   call AllocAry( z%Gammas, p%NumGammas, 'z%Gammas ' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   z%Gammas = 0.0_ReKi ! This will force Gammas to always be 0.0 for LiftMod = 1

   if ( errStat >= AbortErrLev ) return

   p%Chords     = InitInp%Chords

      ! Initialize the Airfoil data
   p%AFIDs                   =  InitInp%AFIDs

   call Init_AFIparams( InitInp, p%AFInfo, UnEc, errStat, errMsg )
      if ( errStat >= AbortErrLev ) return

      ! Set the Other State, indicating whether we have computed valid states in accordance withe the FAST framework
      ! (NOTE: the first call to CalcOutput() will not have valid states)
   OtherState%NoStates = .true.

   ! Set up Output Handling
   p%NumOuts  = 15 * p%NumElem   ! U_Inf_v, U_Ind_v, AoA, Gamma, residual, Fx, Fy, Mz
   p%OutFmt   = "ES11.4e2"
   p%OutSFmt  = "A11"
   p%OutRootName = InitInp%OutRootName
   p%OutSwtch = InitInp%OutSwtch
   p%Delim    = ''

   call AllocAry( InitOut%WriteOutputUnt, p%NumOuts, 'InitOut%WriteOutputUnt' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( InitOut%WriteOutputHdr, p%NumOuts, 'InitOut%WriteOutputHdr' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   call AllocAry( y%WriteOutput, p%NumOuts, 'y%WriteOutput' , errStat2, errMsg2 )
      call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
   if ( errStat >= AbortErrLev ) return

   count = 1
   do j= 1, p%NumElem
      InitOut%WriteOutputHdr(count) = 'UinfX'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '    m/s    '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'UinfY'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '    m/s    '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'UinfZ'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '    m/s    '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'UindX'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '    m/s    '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'UindY'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '    m/s    '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'UindZ'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '    m/s    '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'AoA'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '    deg    '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'Cl'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '     -     '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'Cd'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '     -     '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'Cm'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '     -     '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'Gamma'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '   m^2/s   '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'Res'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '   m^2/s   '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'Fx'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '    N    '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'Fy'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '    N    '
      count = count + 1
      InitOut%WriteOutputHdr(count) = 'Mz'//trim(num2lstr(j))
      InitOut%WriteOutputUnt(count) = '    N-m   '
      count = count + 1
   end do

   if ( p%OutSwtch == 1 .OR. p%OutSwtch == 3 ) then
      call VSM_OpenOutput( VSM_Ver%Name, InitInp%OutRootName, p, InitOut, ErrStat, ErrMsg )
   end if

end subroutine VSM_Init
!==============================================================================

!==============================================================================
subroutine VSM_CalcOutput( t, n, u, p, z, OtherState, m, y, errStat, errMsg )
! Routine for computing outputs, used in both loose and tight coupling.
! Called by : Driver/Glue-code
! Calls  to : SetErrStat
!..............................................................................
   real(DbKi),                    intent(in   )  :: t           !< Current simulation time in seconds
   integer(IntKi),                intent(in   )  :: n           !< Current simulation time step n = 0,1,...
   type(VSM_InputType),           intent(in   )  :: u           !< Inputs at Time
   type(VSM_ParameterType),       intent(in   )  :: p           !< Parameters
   type(VSM_ConstraintStateType), intent(in   )  :: z           !< Input: Constraint states at t;
                                                                    !<  Output: Constraint states at t + Interval
   type(VSM_OtherStateType),      intent(in   )  :: OtherState  !< Other States
   type(VSM_MiscVarType),         intent(inout)  :: m           !< Misc Vars
   type(VSM_OutputType),          intent(inout)  :: y           !< Outputs computed at Time
   integer(IntKi),                intent(  out)  :: errStat     !< Error status of the operation
   character(*),                  intent(  out)  :: errMsg      !< Error message if errStat /= ErrID_None

   character(*), parameter                          :: routineName = 'VSM_CalcOutput'
   type(VSM_ConstraintStateType)                    :: zTmp, z_residual
   real(ReKi)                                       :: alpha(p%NumElem), Fx(p%numElem), Fy(p%numElem), Mz(p%numElem), Cl(p%numElem), Cd(p%numElem), Cm(p%numElem)
   integer(IntKi)                                   :: count, i
   real(ReKi)                                       :: forces(3), moments(3)

   errStat   = ErrID_None           ! no error has occurred
   errMsg    = ""

   if ( p%LiftMod == 2 ) then
      if ( OtherState%NoStates ) then
            ! UpdateStates has never been called, so no real states exist, we need to 'solve for the states' before generating the outputs
         call VSM_CopyConstrState( z, zTmp, 0, errStat, errMsg )
         call VSM_CopyConstrState( z, z_residual, 0, errStat, errMsg )
         call VSM_Solve( t, n, u, p, zTmp, OtherState, m, errStat, errMsg )
            if ( errStat >= AbortErrLev ) return
         call VSM_Compute( p%AirDens, p%NumVolElem, p%numElem, p%ElemLens, u%U_Inf_v, u%x_hat, u%y_hat, p%AFInfo, p%AFIDs, u%deltaf, p%Chords, zTmp%Gammas, m%Phi_v, m%Phi_AB2D_v, y%Vind, y%AoA, Fx, Fy,Mz, y%Cl, y%Cd, y%Cm, z_residual%Gammas, errStat, errMsg)
            if ( errStat >= AbortErrLev ) return
      else
            ! TODO: may want to store this z_residual as a miscvar to avoid the copy here
         call VSM_CopyConstrState( z, z_residual, 0, errStat, errMsg )
         call VSM_Compute_Influence(p%CtrlPtMod, p%KinVisc, p%NumVolElem, p%numElem, u%PtA, u%PtB, u%U_Inf_v, u%x_hat, u%y_hat, p%Chords, m%NoInflow, m%Phi_v, m%Phi_AB2D_v, errStat, errMsg)
            if ( errStat >= AbortErrLev ) return
         call VSM_Compute( p%AirDens, p%NumVolElem, p%numElem, p%ElemLens, u%U_Inf_v, u%x_hat, u%y_hat, p%AFInfo, p%AFIDs, u%deltaf, p%Chords, z%Gammas, m%Phi_v, m%Phi_AB2D_v, y%Vind, y%AoA, Fx, Fy, Mz, y%Cl, y%Cd, y%Cm, z_residual%Gammas, errStat, errMsg)
            if ( errStat >= AbortErrLev ) return
      end if
   else
         ! Compute Loads without induction, all states (Gammas are zero)
      call VSM_CopyConstrState( z, z_residual, 0, errStat, errMsg )
      call VSM_Compute( p%AirDens, p%NumVolElem, p%numElem, p%ElemLens, u%U_Inf_v, u%x_hat, u%y_hat, p%AFInfo, p%AFIDs, u%deltaf, p%Chords, z%Gammas, m%Phi_v, m%Phi_AB2D_v, y%Vind, y%AoA, Fx, Fy, Mz, y%Cl, y%Cd, y%Cm, z_residual%Gammas, errStat, errMsg)
         if ( errStat >= AbortErrLev ) return

   end if

   count = 1
   ! U_Inf_v, U_Ind_v, AoA, Gamma, residual, Fx, Fy, Mz
   do i=1,p%NumElem
      y%Writeoutput(count) = u%U_Inf_v(1,i)
      count = count + 1
      y%Writeoutput(count) = u%U_Inf_v(2,i)
      count = count + 1
      y%Writeoutput(count) = u%U_Inf_v(3,i)
      count = count + 1
      y%Writeoutput(count) = y%Vind(1,i)
      count = count + 1
      y%Writeoutput(count) = y%Vind(2,i)
      count = count + 1
      y%Writeoutput(count) = y%Vind(3,i)
      count = count + 1
      y%Writeoutput(count) = y%AoA(i)*R2D
      count = count + 1
      y%Writeoutput(count) = y%Cl(i)
      count = count + 1
      y%Writeoutput(count) = y%Cd(i)
      count = count + 1
      y%Writeoutput(count) = y%Cm(i)
      count = count + 1
      if ( i > p%NumVolElem ) then
         if ( OtherState%NoStates .and. (p%LiftMod == 2) ) then
            y%Writeoutput(count) = zTmp%Gammas(i-p%NumVolElem)   ! Only do this for the first call to CalcOutput when using vortex method
         else
            y%Writeoutput(count) = z%Gammas(i-p%NumVolElem)
         end if
      else
         y%Writeoutput(count) = 0.0
      end if

      count = count + 1
      if ( i > p%NumVolElem ) then
         y%Writeoutput(count) = z_residual%Gammas(i-p%NumVolElem)
      else
         y%Writeoutput(count) = 0.0
      end if
      count = count + 1
      y%Writeoutput(count) = Fx(i)
      count = count + 1
      y%Writeoutput(count) = Fy(i)
      count = count + 1
      y%Writeoutput(count) = Mz(i)
      count = count + 1

      ! Transform loads to global from local
      forces = u%x_hat(:,i)*Fx(i) + u%y_hat(:,i)*Fy(i)
      y%Loads(1,i) =  forces(1)
      y%Loads(2,i) =  forces(2)
      y%Loads(3,i) =  forces(3)
      moments = u%z_hat(:,i)*Mz(i)
      y%Loads(4,i) =  moments(1)
      y%Loads(5,i) =  moments(2)
      y%Loads(6,i) =  moments(3)

   end do

   if ( p%OutSwtch == 1 .OR. p%OutSwtch == 3 ) then
      call VSM_WriteOutputs( p%UnOutFile, t, y, p, errStat, errMsg )
   end if

end subroutine VSM_CalcOutput
!----------------------------------------------------------------------------------------------------------------------------------
!> This routine is called at the end of the simulation.
subroutine VSM_End( u, p, z, y, OtherState, m, ErrStat, ErrMsg )
!..................................................................................................................................

      type(VSM_InputType),           intent(inout)  :: u           !< System inputs
      type(VSM_ParameterType),       intent(inout)  :: p           !< Parameters
      type(VSM_ConstraintStateType), intent(inout)  :: z           !< Constraint states
      type(VSM_OutputType),          intent(inout)  :: y           !< System outputs
      type(VSM_OtherStateType),      intent(inout)  :: OtherState  !< Other States
      type(VSM_MiscVarType),         intent(inout)  :: m           !< Misc/optimization variables
      integer(IntKi),                intent(  out)  :: ErrStat     !< Error status of the operation
      character(*),                  intent(  out)  :: ErrMsg      !< Error message if ErrStat /= ErrID_None

         ! Initialize ErrStat

      ErrStat = ErrID_None
      ErrMsg  = ""

         ! Destroy the input data:

      call VSM_DestroyInput( u, ErrStat, ErrMsg )

         ! Determine if we need to close the output file

      if ( p%OutSwtch == 1 .OR. p%OutSwtch == 3 ) then
         call VSM_CloseOutput( p%UnOutFile, ErrStat, ErrMsg )
      end if

         ! Destroy the parameter data:
      call VSM_DestroyParam( p, ErrStat, ErrMsg )

         ! Destroy the state data:
      call VSM_DestroyConstrState( z,           ErrStat, ErrMsg )
      call VSM_DestroyMisc( m, ErrStat, ErrMsg )
      call VSM_DestroyOtherState( OtherState, ErrStat, ErrMsg )

         ! Destroy the output data:
      call VSM_DestroyOutput( y, ErrStat, ErrMsg )

end subroutine VSM_End

end module VSM


module rotflip

! This module provides rot90, flipud, fliplr for Fortran like Matlab and NumPy
!
! Note: PGI 19.10 still doesn't run this code correctly
! (compiles but falls through to class default)
!
use, intrinsic:: iso_fortran_env, only: error_unit

implicit none (type, external)

contains

subroutine rot90(A, k)
! https://github.com/numpy/numpy/blob/v1.14.2/numpy/lib/function_base.py#L54-L138

class(*), intent(inout) :: A(:,:)
integer, intent(in), optional :: k
integer :: r

r = 1
if (present(k)) r = k

select type (A)
  type is (integer)
    select case (modulo(r,4))
      case (0)  ! unmodified
      case (1)
        call flip(A,1)
        A = transpose(A)
      case (2)
        call flip(A,0)
      case (3)
        A = transpose(A)
        call flip(A, 1)
    end select
  type is (real)
    select case (modulo(r,4))
      case (0)  ! unmodified
      case (1)
        call flip(A,1)
        A = transpose(A)
      case (2)
        call flip(A,0)
      case (3)
        A = transpose(A)
        call flip(A, 1)
    end select
  class default
    error stop 'rot90: not real or integer'
end select

end subroutine rot90

subroutine flip(A, d)

class(*), intent(inout) :: A(:,:)
integer, intent(in) :: d
integer :: M, N

M = size(A,1)
N = size(A,2)

select type (A)
  type is (integer)
    select case (d)
      case (0)  ! flip both dimensions
        A = A(M:1:-1, N:1:-1)
      case (1)
        A = A(M:1:-1, :)
      case (2)
        A = A(:, N:1:-1)
      case default
        error stop 'bad flip dimension, 2-D only  (1 or 2), or 0 for both dimensions'
    end select
  type is (real)
    select case (d)
      case (0)  ! flip both dimensions
        A = A(M:1:-1, N:1:-1)
      case (1)
        A = A(M:1:-1, :)
      case (2)
        A = A(:, N:1:-1)
      case default
        error stop 'bad flip dimension, 2-D only  (1 or 2), or 0 for both dimensions'
    end select
  class default
    error stop 'flip: not real or integer'
end select

end subroutine flip

subroutine flipud(A)

class(*), intent(inout) :: A(:,:)

select type (A)
  type is (real)
    call flip(A,1)
  type is (integer)
    call flip(A,1)
  class default
    error stop 'flipud: not an integer or real'
end select

end subroutine flipud

subroutine fliplr(A)

class(*), intent(inout) :: A(:,:)

select type (A)
  type is (real)
    call flip(A,2)
  type is (integer)
    call flip(A,2)
  class default
    error stop 'fliplr: not an integer or real'
end select

end subroutine fliplr

end module rotflip


program t
  print *, (/ 1,2 /) <= (/ 2, 3 /)
end program t