!
!     (c) 2019-2020 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract
!     "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)",
!     contract # NRC-HQ-60-17-C-0007
!
PROGRAM main
  USE kind_parameters, ONLY : r8k
  USE assertions_interface, ONLY : assert
  USE array_functions_interface, ONLY : OPERATOR(.catRows.), OPERATOR(.catColumns.), OPERATOR(.columnVectors.)
  IMPLICIT NONE

  REAL(r8k), PARAMETER, DIMENSION(*) :: u = [1.,2.,3.], v = [4.,5.,6.]
    !! Define two 3D vectors as test data
  INTEGER, PARAMETER :: num_vectors = SIZE( ["u","v"], 1 ), space_dimension=3

  test_catcolumns: BLOCK
    !! Store two 3D vectors u and v in columns of lhs and rhs, respectively and test the concatenation of the columns
    REAL(r8k), PARAMETER, DIMENSION(space_dimension,0) :: empty=RESHAPE( [REAL(r8k)::], [space_dimension,0])
      !! Array of zero 3D vectors
    REAL(r8k), PARAMETER, DIMENSION(*,*) :: lhs = RESHAPE( [u,v] , SHAPE=[SIZE(u,1), num_vectors] )
      !! Store u and v in columns of lhs
    REAL(r8k), PARAMETER, DIMENSION(*,*) :: rhs = 2.*lhs
      !! Store 2u and 2v in columns of rhs
    REAL(r8k), PARAMETER, DIMENSION(*,*) :: expected_result = RESHAPE( [ [u,v], 2.*[u,v] ], SHAPE=[SIZE(u,1), 2*num_vectors] )
      !! Expected result of concatenating the columns of lhs and rhs
    CALL assert( (empty .catColumns. (lhs .catColumns. rhs)) == expected_result ,"columns concatenated")
  END BLOCK test_catcolumns

  test_catrows: BLOCK
    !! Store two 3D vectors u and v in rows of lhs and rhs, respectively and test the concatenation of the rows
    INTEGER, PARAMETER :: space_dimension = SIZE(u,1 )
    REAL(r8k), DIMENSION(num_vectors,space_dimension) :: lhs , rhs
    REAL(r8k), DIMENSION(2*num_vectors,space_dimension) :: expected_result

    lhs(1,1:SIZE(u,1))  = u  !! Store u in 1st row of lhs
    lhs(2,1:SIZE(u,1))  = v  !! Store v in 2nd row of lhs
    rhs = 2.*lhs !! Store 2u and 2v in 1st and 2nd rows, respectively, of rhs
    expected_result(1:2,1:SIZE(u,1)) = lhs
    expected_result(3:4,1:SIZE(v,1)) = rhs

    CALL assert( (lhs .catRows. rhs) == expected_result ,"rows concatenated")
  END BLOCK test_catrows

  test_column_vectors: BLOCK
    INTEGER, PARAMETER :: n(4)=[2,2,2,3] !! [nx,ny,nz,nspace_dim]
    REAL(r8k), DIMENSION(n(1),n(2),n(3),n(4)) :: vector_field
    LOGICAL vectors_match(n(4),PRODUCT(n(1:3)))
    INTEGER i, j, k

    vector_field(1,1,1,:) = [0.,0.,0.]
    vector_field(2,1,1,:) = [1.,0.,0.]
    vector_field(1,2,1,:) = [0.,1.,0.]
    vector_field(2,2,1,:) = [1.,1.,0.]

    vector_field(1,1,2,:) = [0.,0.,1.]
    vector_field(2,1,2,:) = [1.,0.,1.]
    vector_field(1,2,2,:) = [0.,1.,1.]
    vector_field(2,2,2,:) = [1.,1.,1.]

    ASSOCIATE( colvec => .columnVectors. vector_field )
      CALL assert(SIZE(colvec)==SIZE(vector_field),"colummn-vector array size preserved")
      DO CONCURRENT(i=1:n(1), j=1:n(2), k=1:n(3))
        ASSOCIATE( id => (k-1)*PRODUCT(n(1:2)) + (j-1)*n(1) + i )
          vectors_match(:,id) = ( colvec(:,id) == vector_field(i,j,k,:) )
        END ASSOCIATE
      END DO
    END ASSOCIATE
    CALL assert( ALL(vectors_match),"colVectors extracted vector field")

  END BLOCK test_column_vectors

  print *,"Test passed."
END PROGRAM


      FUNCTION esat(T)

      IMPLICIT NONE

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CC  PURPOSE:  TO CALCULATE VALUES OF SAT. VAPOR PRESSURE (E)
CC            SUBSTITUTES LOOK-UP TABLES ASSOCIATED WITH THE DATA
CC            BLOCK  /VAPPRS/ .
CC            FORMULAS AND CONSTANTS FROM ROGERS AND YAU, 1989.
CC
CC                         ADDED BY PABLO J. GRUNMANN, 7/9/97.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      REAL esat
      REAL LW
      REAL T
      REAL CPV
      REAL RV
      REAL CW
      REAL ESO
      REAL TO
      REAL LVH2O

      PARAMETER (LVH2O = 2.501000E+6)

      PARAMETER (CPV = 1870.)
      PARAMETER  (RV = 461.5)
      PARAMETER  (CW = 4187.)
      PARAMETER (ESO = 611.2)
      PARAMETER  (TO = 273.16)
C
C     ABOUT THE PARAMETERS:
C
C     EPS ---------- WATER - DRY AIR MOLECULAR MASS RATIO, EPSILON
C
C   VALUES FOR SPECIFIC HEAT CAPACITY AND INDIVIDUAL GAS CONSTANTS
C   IN [JOULES/(KG*KELVIN)] UNITS.
C
C     DRY AIR:
C             CP, CV
C     WATER VAPOR:
C                 CVV = 1410.
C                 CPV = 1870.
C                 RV  =  461.5
C     LIQUID WATER:
C                  CW = 4187.
C
C     ESO = ES(TO) = SAT. VAPOR PRESSURE (IN PASCAL) AT T=TO
C      TO = 273.16
C_______________________________________________________________________
C
C     CLAUSIUS-CLAPEYRON: DES/DT = L*ES/(RV*T^2)
C
C
          LW = LVH2O - ( CW - CPV ) * ( T - TO )
          esat = ESO*EXP (LW*(1/TO - 1/T)/RV)
C
          RETURN
          END


MODULE SEDOL_CHECK
  IMPLICIT NONE
  CONTAINS

  FUNCTION Checkdigit(c)
    CHARACTER :: Checkdigit
    CHARACTER(6), INTENT(IN) :: c
    CHARACTER(36) :: alpha = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    INTEGER, DIMENSION(6) :: weights = (/ 1, 3, 1, 7, 3, 9 /), temp
    INTEGER :: i, n

    DO i = 1, 6
      temp(i) = INDEX(alpha, c(i:i)) - 1
    END DO
    temp = temp * weights
    n = MOD(10 - (MOD(SUM(temp), 10)), 10)
    Checkdigit = ACHAR(n + 48)
  END FUNCTION Checkdigit

END MODULE SEDOL_CHECK

PROGRAM SEDOLTEST
  USE SEDOL_CHECK
  IMPLICIT NONE

  CHARACTER(31) :: valid = "0123456789BCDFGHJKLMNPQRSTVWXYZ"
  CHARACTER(6) :: codes(10) = (/ "710889", "B0YBKJ", "406566", "B0YBLH", "228276" ,  &
                                 "B0YBKL", "557910", "B0YBKR", "585284", "B0YBKT" /)
  CHARACTER(7) :: sedol
  INTEGER :: i, invalid

  DO i = 1, 10
    invalid = VERIFY(codes(i), valid)
    IF (invalid == 0) THEN
      sedol = codes(i)
      sedol(7:7) = Checkdigit(codes(i))
    ELSE
      sedol = "INVALID"
    END IF
    WRITE(*, "(2A9)") codes(i), sedol
  END DO

END PROGRAM SEDOLTEST


c
c
c ==============================================================
       subroutine qinit(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux)
c ==============================================================

      implicit none
      double precision q(1-mbc:maxmx+mbc, meqn)
      double precision aux(1-mbc:maxmx+mbc, *)

      integer maxmx,meqn,mbc,mx,maux
      double precision xlower,dx,flumegeo,hinit

      !local
      integer i
      double precision h,pimin,theta,xcell

      include "digparamsdec.i"
      include "digparamscommon.i"

      do i=1,mx
         xcell = xlower + (i-0.5d0)*dx
         if (init_htype.eq.0) then
            h = max(0.d0,flumegeo(xcell))
         elseif (init_htype = 1) then
            !you must supply a function hinit(xcell)
         endif
         q(i,1) = h
         theta = aux(i,i_theta)
         q(i,2)= 0.d0
         q(i,3)= q(i,1)*m0
         q(i,4)= rho_f*grav*q(i,1)*cos(theta)
      enddo

      call calcaux(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux)

      if (init_ptype.eq.1) then
         pimin = 1.d0
         call calcpmin(maxmx,meqn,mbc,mx,xlower,dx,pimin,q,maux,aux)
         do i = 1,mx
            theta = aux(i,i_theta)
            q(i,4) = max(pimin,0.d0)*rho_f*grav*cos(theta)*q(i,1)
         enddo
         p_initialized = 1
      endif

      return
      end

c=======================================================================
      function flumegeo(x)
c
c     function to return the depth, given x, for the flume hopper
c     uses parameters set in digparams
c=======================================================================

      implicit none

      double precision x,h,flumegeo
      double precision pi,x0,x1,x2,x3,y0,y1,y2,y3,m

      include "digparamsdec.i"
      include "digparamscommon.i"

      pi = 3.14159
      x0 = -hopperlen
      x3 = 0.d0
      x2 = -hmax*cos(0.5d0*pi - theta1)
      x1 = x2 - hoppertop*cos(theta1 - hopperangle)

      y0 = 0.d0
      y2 = hmax*sin(0.5d0*pi - theta1)
      y1 = y2 - hoppertop*sin(theta1 - hopperangle)
      y3 = 0.d0

      if (x.ge.x0 .and. x.lt.x1) then
         m = (y1-y0)/(x1-x0)
         h = y0 + m*(x-x0)
      elseif (x.ge.x1 .and. x.lt.x2) then
         m = (y2-y1)/(x2-x1)
         h = y1 + m*(x-x1)
      elseif (x.ge.x2 .and. x.lt.x3) then
         m = (y3-y2)/(x3-x2)
         h = y2 + m*(x-x2)
      else
         h = 0.d0
      endif
c      h = 2.d0*exp(-(x)**2)

      flumegeo = h
      return
      end

c ================================================================
       subroutine calcpmin(maxmx,meqn,mbc,mx,xlower,dx,pimin,q,maux,aux)
c ================================================================

      implicit none
      double precision q(1-mbc:maxmx+mbc, meqn)
      double precision aux(1-mbc:maxmx+mbc, *)

      integer maxmx,meqn,mbc,mx,maux
      double precision xlower,dx

      !local
      integer i
      double precision h,hr,hl,rhol,rhor,rho,thetal,thetar,theta,phi
      double precision del,taumag,pimin,pcrit

      include "digparamsdec.i"
      include "digparamscommon.i"

      do i=1,mx
         hr = q(i,1)
         hl = q(i-1,1)
         h = 0.5d0*(hr + hl)
         if (h.lt.dry_tol) then
            cycle
         endif
         phi = 0.5d0*(aux(i,i_phi) + aux(i-1,i_phi))
         thetal = aux(i-1,i_theta)
         thetar = aux(i,i_theta)
         theta = 0.5d0*(thetal + thetar)

         rhol = aux(i-1,i_rho)
         rhor = aux(i,i_rho)
         rho = 0.5d0*(rhol+rhor)
*        ! determine pressure min ratio
         del = rho*0.5d0*grav*(cos(thetar)*hr**2 - cos(thetal)*hl**2)
     &         - rho*grav*h*sin(theta)*dx
         taumag = abs(del/dx)
         pcrit = rho*h*grav - taumag/tan(phi)
         pimin = min(pimin,pcrit/(rho_f*grav*cos(theta)*h))
      enddo

      return
      end


C     LAST UPDATE 17/03/95
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE RECIP(U,V,R,Z)
      IMPLICIT NONE
C
C Purpose: Converts from film space (U,V) to reciprocal space (R,Z)
C
C Calls   0:
C Called by: REFALL
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      INCLUDE 'FIXPAR.COM'
C
C Scalar Arguments:
C
      REAL U,V,R,Z
C
C Local variables:
C
      REAL D(3),DR(3),PHI(3,3)
      REAL DNORM,DSQ,RSQ,TEMP
      REAL CRX,SRX,CRY,SRY,CRZ,SRZ
      INTEGER J,K
C
C Intrinsic Functions:
C
      INTRINSIC COS,SIN,SQRT
C
C-----------------------------------------------------------------------
C
C========Form sines and cosines of detector rotation angles
C
      CRX = COS(ROTX)
      SRX = SIN(ROTX)
      CRY = COS(ROTY)
      SRY = SIN(ROTY)
      CRZ = COS(ROTZ)
      SRZ = SIN(ROTZ)
C
C========Form detector rotation matrix RzRyRx
C
      PHI(1,1) = CRZ*CRY
      PHI(1,2) = CRZ*SRY*SRX + SRZ*CRX
      PHI(1,3) = -CRZ*SRY*CRX + SRZ*SRX
      PHI(2,1) = -SRZ*CRY
      PHI(2,2) = -SRZ*SRY*SRX + CRZ*CRX
      PHI(2,3) = SRZ*SRY*CRX + CRZ*SRX
      PHI(3,1) = SRY
      PHI(3,2) = -CRY*SRX
      PHI(3,3) = CRY*CRX
C
C========Set up detector space vector and normalize
C
      DNORM = SQRT(SDD*SDD+U*U+V*V)
      D(1) = SDD/DNORM
      D(2) = U/DNORM
      D(3) = V/DNORM
C
C========Apply detector orientation matrix
C
      DO 20 J=1,3
         DR(J) = 0.0
         DO 10 K=1,3
            DR(J) = DR(J) + PHI(J,K)*D(K)
 10      CONTINUE
 20   CONTINUE
C
C========DR(1) = cos(2theta) and DR(3) = sin(chi) from rotated vector
C
      TEMP = 1.0 - DR(1)
      IF(TEMP.LT.0.0)TEMP = 0.0
      DSQ = 2.0*TEMP/(WAVE*WAVE)
      Z = (SIN(TILT)*TEMP+COS(TILT)*DR(3))/WAVE
      RSQ = DSQ - Z*Z
      IF(RSQ.LT.0.0)RSQ = 0.0
      R = SQRT(RSQ)
C
      RETURN
      END


       SUBROUTINE W3FA01(P,T,RH,TD,PLCL,TLCL)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FA01         COMPUTE LIFTING CONDENDSATION LEVEL
C   AUTHOR: HOWCROFT,J.      ORG: W/NMC342   DATE: 79-07-01
C
C ABSTRACT: GIVEN THE PRESSURE, TEMPERATURE AND RELATIVE HUMIDITY OF
C   AN AIR PARCEL AT SOME POINT IN THE ATMOSPHERE, CALCULATE THE
C   DEWPOINT TEMPERATURE AND THE PRESSURE AND TEMPERATURE OF THE
C   LIFTING CONDENSATION LEVEL.
C
C PROGRAM HISTORY LOG:
C   79-07-01  J.HOWCROFT
C   89-01-24  R.E.JONES   CHANGE TO MICROSOFT FORTRAN 4.10
C   90-06-11  R.E.JONES   CHANGE TO SUN FORTRAN 1.3
C   91-03-29  R.E.JONES   CONVERT TO SiliconGraphics FORTRAN
C   93-03-29  R.E.JONES   ADD SAVE STATEMENT
C   95-09-25  R.E.JONES   PUT IN CRAY W3 LIBRARY
C
C USAGE: CALL W3FA01(P,T,RH,TD,PLCL,TLCL)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     P      ARG LIST  PARCEL PRESSURE IN MILLIBARS
C     T      ARG LIST  PARCEL TEMPERATURE IN DEGREES CELSIUS
C     RH     ARG LIST  PARCEL RELATIVE HUMIDITY IN PERCENT
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     TD     ARG LIST  DEWPOINT TEMPERATURE IN DEGREES CELSIUS
C     PLCL   ARG LIST  PRESSURE OF LCL IN MILLIBARS
C     TLCL   ARG LIST  TEMPERATURE AT LCL IN DEGREES CELSIUS
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     ABS    ALOG   ALOG10 EXP                                SYSLIB
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916/256, J916/2048
C
C$$$
C
      SAVE
C
C        DEFINITION OF THE POTENTIAL TEMPERATURE
C
      POTEMP(T,P) = (T+273.16)*((1000./P)**0.2857)
C
C        TETENS FORMULA WITH NATURAL BASE
C
      VAPRES(T)   = 6.11*EXP((17.2694*T)/(T+237.3))
C
C        BEGIN
C
      IF (RH.LT.100) GO TO 10
        PLCL = P
        TLCL = T
        TD   = T
        GO TO 40
C
C       CALCULATE DEW POINT FROM RH AND T
C
   10 CONTINUE
        AR    = ALOG(RH*0.01)/17.269
        TD    = (-237.3*(AR+1.0)*T - AR*237.3**2)/(AR*T+237.3*(AR-1.0))
        E     = VAPRES(TD)
        W     = (0.622*E)/(P-E)
        THETA = POTEMP(T,P)
C
C        DO STACKPOLE'S THING AS IN JOUR APPL MET, VOL 6, PP 464-467.
C
        EPS  = 0.1
        CGES = 0.5
C
C        CONSTANTS   -35.86 = 237.30 - 273.16
C                    2048.7 = 273.16 *   7.50
C
        PGES = (((CGES*(-35.86)+2048.7)/(THETA*(7.5-CGES)))**3.5)*1000.
C
C        START ITERATION.
C
   20 CONTINUE
        CGES = ALOG10((PGES*W)/(6.11*(0.622+W)))
        PLCL = (((CGES*(-35.86)+2048.7)/(THETA*(7.5-CGES)))**3.5)*1000.
        IF (ABS(PLCL-PGES) .LT. EPS)  GO TO 30
        PGES = PLCL
        GO TO 20
C
   30 CONTINUE
        TLCL   = (CGES * 237.3) / (7.5 - CGES)
C
C        FALL THRU WITH  P,T  OF THE LIFTED CONDENSATION LEVEL.
C
   40 CONTINUE
        RETURN
      END


Calculates "left factorials", in sequence, and shows some.
      INTEGER ENUFF,BASE	!Some parameters.
      PARAMETER (BASE = 10, ENUFF = 40000)	!This should do.
      INTEGER LF,F(ENUFF),LS,S(ENUFF)	!Big numbers in digits F(1:LF), S(1:LS)
      INTEGER N		!A stepper.
      INTEGER L		!Locates digits.
      INTEGER C		!A carry for arithmetic.
      INTEGER MSG	!I/O unit number.

      MSG = 6	!Standard output.
      LF = 1; F(1) = 1	!Set F = 1 = 0!
      LS = 1; S(1) = 0	!Set S = 0 = !0
      WRITE (MSG,1) 0,0	!Pre-emptive first result.
    1 FORMAT ("!",I0,T6,666I1)	!This will do for reasonable sizes.

   10 DO N = 1,10000	!Step away.
Commence the addition of F to S.
   20   C = 0		!Clear the carry.
        DO L = 1,MIN(LF,LS)	!First, both S and F have low-order digits.
          C = S(L) + F(L) + C		!So, a three-part addition.
          S(L) = MOD(C,BASE)		!Place the digit.
          C = C/BASE			!Carry to the next digit up.
        END DO			!Ends with L and C important.
Careful. L fingers the next digit up, and C is to carry in to that digit.
        IF (LF.GT.LS) THEN	!Has F more digits than S?
          DO L = L,LF		!Yes. Continue adding, with leading zero digits from S.
            C = F(L) + C		!Thus.
            LS = LS + 1			!Another digit for S.
            S(LS) = MOD(C,BASE)		!Place.
            C = C/BASE			!Carry to the next digit up.
          END DO		!Continue to the end of F.
        END IF			!Either way, F has been added in.
Continue carrying, with C for digit L.
        DO WHILE(C .GT. 0)	!Extend the carry into S.
          IF (L.LE.LS) THEN		!If F had fewer digits than S,
            C = C + S(L)		!S digits await.
           ELSE			!Otherwise,
            LS = LS + 1			!Extend S.
          END IF		!C is ready.
          S(L) = MOD(C,BASE)	!Place it.
          C = C/BASE		!The carry for the next digit up.
          L = L + 1		!Locate it.
        END DO			!Perhaps a multi-digit carry.
Contemplate what to do with the current S.
        IF (N.LE.10) THEN		!First selection: !N for 0 to 10.
          WRITE (MSG,1) N,S(LS:1:-1)		!Show the value. Digits from the high-order end down.
        ELSE IF (20.LE.N .AND. N.LE.110) THEN	!Second selection: for 20 to 110,
          IF (MOD(N,10).EQ.0) WRITE (MSG,1) N,S(LS:1:-1)	!Show only every tenth.
        ELSE					!Third selection
          IF (MOD(N,1000).EQ.0) WRITE (MSG,21) N,LS	!Show only the number of digits.
   21     FORMAT ("!",I0," has ",I0," digits.")		!Which is why BASE is only 10.
        END IF				!So much for the selection of output.
Calculate the next factorial, ready for the next one up.
        C = 0		!Start a multiply.
        DO L = 1,LF	!Step up the digits to produce N! in F.
          C = F(L)*N + C	!A digit.
          F(L) = MOD(C,BASE)	!Place.
          C = C/BASE		!Extract the carry.
        END DO		!On to the next digit.
        DO WHILE(C .GT. 0)	!While any carry remains,
          LF = LF + 1			!Add another digit to F.
          IF (LF.GT.ENUFF) STOP "F overflow!"	!Perhaps not.
          F(LF) = MOD(C,BASE)		!The digit.
          C = C/BASE			!Carry to the next digit up.
        END DO			!If there is one, as when N > BASE.
      END DO		!On to the next result.
      END	!Ends with a new factorial that won't be used.


module vector_analysis_routines

    use spherepack_precision, only: &
        wp, & ! working precision
        ip, & ! integer precision
        PI, &
        even, odd

    use type_SpherepackUtility, only: &
        SpherepackUtility, &
        get_lvhaec, &
        get_lvhagc, &
        get_lvhaes, &
        get_lvhags

    use gaussian_latitudes_and_weights_routines, only: &
        compute_gaussian_latitudes_and_weights

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    public :: vhagc, vhagci, initialize_vhaec
    public :: vhaes, vhaesi, initialize_vhaes
    public :: vhaec, vhaeci, initialize_vhagc
    public :: vhags, vhagsi, initialize_vhags
    public :: VectorForwardTransform
    public :: VectorAnalysisUtility

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: TWO = 2.0_wp
    real(wp), parameter :: FOUR = 4.0_wp

    type, public :: VectorForwardTransform
    contains
        ! Type-bound procedures
        procedure, nopass :: vhaec
        procedure, nopass :: vhagc
        procedure, nopass :: vhaes
        procedure, nopass :: vhags
        procedure, nopass :: initialize_vhaec
        procedure, nopass :: initialize_vhaes
        procedure, nopass :: initialize_vhagc
        procedure, nopass :: initialize_vhags
    end type VectorForwardTransform

    type, public, extends(SpherepackUtility) :: VectorAnalysisUtility
    contains
        procedure, nopass :: check_vector_analysis_inputs
        procedure         :: analysis_setup
    end type VectorAnalysisUtility

    ! Declare interfaces for submodule implementation
    interface
        module subroutine vhaec(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
            mdab, ndab, wvhaec, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: ityp
            integer(ip), intent(in)  :: nt
            real(wp),    intent(in)  :: v(idvw, jdvw, nt)
            real(wp),    intent(in)  :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(out) :: br(mdab, ndab, nt)
            real(wp),    intent(out) :: bi(mdab, ndab, nt)
            real(wp),    intent(out) :: cr(mdab, ndab, nt)
            real(wp),    intent(out) :: ci(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wvhaec(:)
            integer(ip), intent(out) :: ierror
        end subroutine vhaec

        module subroutine vhaes(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
            mdab, ndab, wvhaes, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: ityp
            integer(ip), intent(in)  :: nt
            real(wp),    intent(in)  :: v(idvw, jdvw, nt)
            real(wp),    intent(in)  :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(out) :: br(mdab, ndab, nt)
            real(wp),    intent(out) :: bi(mdab, ndab, nt)
            real(wp),    intent(out) :: cr(mdab, ndab, nt)
            real(wp),    intent(out) :: ci(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wvhaes(:)
            integer(ip), intent(out) :: ierror
        end subroutine vhaes

        module subroutine vhagc(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
            mdab, ndab, wvhagc, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: ityp
            integer(ip), intent(in)  :: nt
            real(wp),    intent(in)  :: v(idvw, jdvw, nt)
            real(wp),    intent(in)  :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(out) :: br(mdab, ndab, nt)
            real(wp),    intent(out) :: bi(mdab, ndab, nt)
            real(wp),    intent(out) :: cr(mdab, ndab, nt)
            real(wp),    intent(out) :: ci(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wvhagc(:)
            integer(ip), intent(out) :: ierror
        end subroutine vhagc

        module subroutine vhags(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
            mdab, ndab, wvhags, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: ityp
            integer(ip), intent(in)  :: nt
            real(wp),    intent(in)  :: v(idvw, jdvw, nt)
            real(wp),    intent(in)  :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(out) :: br(mdab, ndab, nt)
            real(wp),    intent(out) :: bi(mdab, ndab, nt)
            real(wp),    intent(out) :: cr(mdab, ndab, nt)
            real(wp),    intent(out) :: ci(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wvhags(:)
            integer(ip), intent(out) :: ierror
        end subroutine vhags

        module subroutine vhaeci(nlat, nlon, wvhaec, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wvhaec(:)
            integer(ip), intent(out) :: ierror
        end subroutine vhaeci

        module subroutine vhaesi(nlat, nlon, wvhaes, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wvhaes(:)
            integer(ip), intent(out) :: ierror
        end subroutine vhaesi

        module subroutine vhagci(nlat, nlon, wvhagc, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wvhagc(:)
            integer(ip), intent(out) :: ierror
        end subroutine vhagci

        module subroutine vhagsi(nlat, nlon, wvhags, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wvhags(:)
            integer(ip), intent(out) :: ierror
        end subroutine vhagsi
    end interface

contains

    pure subroutine check_vector_analysis_inputs(nlat, nlon, vector_symmetries, &
        idvw, jdvw, order_m, degree_n, number_of_syntheses, &
        required_wavetable_size, wavetable, error_flag)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: vector_symmetries
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        integer(ip), intent(in)  :: order_m
        integer(ip), intent(in)  :: degree_n
        integer(ip), intent(in)  :: number_of_syntheses
        integer(ip), intent(in)  :: required_wavetable_size
        real(wp),    intent(in)  :: wavetable(:)
        integer(ip), intent(out) :: error_flag

        !  Check calling arguments
        if (nlat < 3) then
            error_flag = 1
        else if (nlon < 1) then
            error_flag = 2
        else if (vector_symmetries < 0 .or. vector_symmetries > 8) then
            error_flag = 3
        else if (number_of_syntheses < 0) then
            error_flag = 4
        else if ( &
            (vector_symmetries <= 2 .and. idvw < nlat) &
            .or. &
            (vector_symmetries > 2 .and. idvw < (nlat + 1)/2) &
            ) then
            error_flag = 5
        else if (jdvw < nlon) then
            error_flag = 6
        else if (order_m < min(nlat, (nlon + 1)/2)) then
            error_flag = 7
        else if (degree_n < nlat) then
            error_flag = 8
        else if (size(wavetable) < required_wavetable_size) then
            error_flag = 9
        else
            error_flag = 0
        end if

    end subroutine check_vector_analysis_inputs

    subroutine analysis_setup(self, idvw, jdvw, mdab, ndab, &
        bi, br, ci, cr, even_stride, idv, imid, imm1, ityp, &
        mmax, nlat, nlon, nt, odd_stride,  v, ve, vo, w, we, wo, wrfft)

        class(VectorAnalysisUtility), intent(inout) :: self
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(out) :: bi(mdab, ndab, nt)
        real(wp),    intent(out) :: br(mdab, ndab, nt)
        real(wp),    intent(out) :: ci(mdab, ndab, nt)
        real(wp),    intent(out) :: cr(mdab, ndab, nt)
        integer(ip), intent(out) :: even_stride
        integer(ip), intent(in)  :: idv
        integer(ip), intent(in)  :: imid
        integer(ip), intent(out) :: imm1
        integer(ip), intent(in)  :: ityp
        integer(ip), intent(out) :: mmax
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: nt
        integer(ip), intent(out) :: odd_stride
        real(wp),    intent(in)  :: v(idvw, jdvw, nt)
        real(wp),    intent(out) :: ve(idv, nlon, nt)
        real(wp),    intent(out) :: vo(idv, nlon, nt)
        real(wp),    intent(in)  :: w(idvw, jdvw, nt)
        real(wp),    intent(out) :: we(idv, nlon, nt)
        real(wp),    intent(out) :: wo(idv, nlon, nt)
        real(wp),    intent(in)  :: wrfft(:)

        ! Local variables
        integer(ip) :: k, i
        real(wp)    :: tsn, fsn

        mmax = min(nlat, (nlon + 1)/2)

        select case (mod(nlat, 2))
            case (0)
                imm1 = imid
                odd_stride = nlat
                even_stride = nlat-1
            case default
                imm1 = imid-1
                odd_stride = nlat-1
                even_stride = nlat
        end select

        ! Set multipliers
        tsn = TWO/nlon
        fsn = FOUR/nlon

        select case (ityp)
            case (0:2)
                do k=1, nt
                    do i=1, imm1
                        ve(i, :, k) = tsn * (v(i, :nlon, k) + v((nlat + 1)-i, :nlon, k))
                        vo(i, :, k) = tsn * (v(i, :nlon, k) - v((nlat + 1)-i, :nlon, k))
                        we(i, :, k) = tsn * (w(i, :nlon, k) + w((nlat + 1)-i, :nlon, k))
                        wo(i, :, k) = tsn * (w(i, :nlon, k) - w((nlat + 1)-i, :nlon, k))
                    end do
                end do
            case default
                do k=1, nt
                    ve(:imm1, :, k) = fsn * v(:imm1, :nlon, k)
                    vo(:imm1, :, k) = fsn * v(:imm1, :nlon, k)
                    we(:imm1, :, k) = fsn * w(:imm1, :nlon, k)
                    wo(:imm1, :, k) = fsn * w(:imm1, :nlon, k)
                end do
        end select

        if (mod(nlat, 2) /= 0) then
            do k=1, nt
                ve(imid, :, k) = tsn * v(imid, :nlon, k)
                we(imid, :, k) = tsn * w(imid, :nlon, k)
            end do
        end if

        do k=1, nt
            call self%hfft%forward(idv, nlon, ve(:, :, k), idv, wrfft)
            call self%hfft%forward(idv, nlon, we(:, :, k), idv, wrfft)
        end do

        ! Set polar coefficients to zero
        br = ZERO
        bi = ZERO

        ! Set azimuthal coefficients to zero
        cr = ZERO
        ci = ZERO

    end subroutine analysis_setup

    subroutine initialize_vhaec(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lvhaec, vhaeci, error_flag)

    end subroutine initialize_vhaec

    subroutine initialize_vhaes(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lvhaes, vhaesi, error_flag)

    end subroutine initialize_vhaes

    subroutine initialize_vhagc(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lvhagc, vhagci, error_flag)

    end subroutine initialize_vhagc

    subroutine initialize_vhags(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lvhags, vhagsi, error_flag)

    end subroutine initialize_vhags

end module vector_analysis_routines


module m_Poisson
  use MPI
  use decomp_2d
  use m_TypeDef
  use m_LogInfo
  use m_Parameters
  use m_MeshAndMetries
  use iso_c_binding
  use m_Variables,only: mb1
  use m_Tools,only: InverseTridiagonal,InversePeriodicTridiagonal
  implicit none
  private
  include "fftw3.f03"

  ! engine-specific global variables
  real(RK),save::normfft
  type(C_PTR),save::fwd_plan_x,bwd_plan_x,fwd_plan_z,bwd_plan_z
  real(RK),save,allocatable,dimension(:)::ak1,ak3 ! modified waves in x-dir and z-dir

  public:: InitPoissonSolver,clcPPE
contains

  !******************************************************************
  ! InitPoissonSolver
  !******************************************************************
  subroutine InitPoissonSolver()
    implicit none

    ! locals
    real(RK)::wa1,wa3
    integer::i,k,iErr01, iErr02,iErrSum,plan_type
    type(fftw_iodim),dimension(1)::iodim,iodim_howmany
    integer(C_FFTW_R2R_KIND),dimension(1)::kind_fwd,kind_bwd
    real(RK),dimension(xsize(1),xsize(2),xsize(3))::arrx1,arrx2
    real(RK),dimension(zsize(1),zsize(2),zsize(3))::arrz1,arrz2

    if(FFTW_plan_type == 1) then
      plan_type=FFTW_MEASURE
    else
      plan_type=FFTW_ESTIMATE
    endif

    ! fft in x
    iodim(1)%n  = xsize(1)
    iodim(1)%is = 1
    iodim(1)%os = 1
    iodim_howmany(1)%n  = xsize(2)*xsize(3)
    iodim_howmany(1)%is = xsize(1)
    iodim_howmany(1)%os = xsize(1)
    kind_fwd = FFTW_R2HC
    kind_bwd = FFTW_HC2R
    fwd_plan_x = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,arrx1,arrx2,kind_fwd,plan_type)
    bwd_plan_x = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,arrx1,arrx2,kind_bwd,plan_type)

    ! fft in z
    iodim(1)%n  = zsize(3)
    iodim(1)%is = zsize(1)*zsize(2)
    iodim(1)%os = zsize(1)*zsize(2)
    iodim_howmany(1)%n  = zsize(1)*zsize(2)
    iodim_howmany(1)%is = 1
    iodim_howmany(1)%os = 1
    kind_fwd = FFTW_R2HC
    kind_bwd = FFTW_HC2R
    fwd_plan_z = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,arrz1,arrz2,kind_fwd,plan_type)
    bwd_plan_z = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,arrz1,arrz2,kind_bwd,plan_type)
    normfft = one/(real(nxc,RK)*real(nzc,RK))

    ! modified wave number in x1 and x3 direct.
    allocate(ak1(nxc), Stat =iErr01 )
    allocate(ak3(nzc), Stat =iErr02 )
    iErrSum=abs(iErr01)+abs(iErr02)
    if(iErrSum /= 0) call MainLog%CheckForError(ErrT_Abort,"InitPoissonSolver","Allocation failed")

    do i=1,nxc
      wa1= twopi*real(i-1,RK)/real(nxc,RK)
      ak1(i)=rdx2/288.0_RK*(cos(three*wa1)-54.0_RK*cos(two*wa1)+783.0_RK*cos(wa1)-730.0_RK)
    enddo
    do k=1,nzc
      wa3= twopi*real(k-1,RK)/real(nzc,RK)
      ak3(k)=rdz2/288.0_RK*(cos(three*wa3)-54.0_RK*cos(two*wa3)+783.0_RK*cos(wa3)-730.0_RK)
    enddo
  end subroutine InitPoissonSolver

  !******************************************************************
  ! clcPPE
  !******************************************************************
  subroutine clcPPE(prsrc, prphiHalo)
    implicit none
    real(RK),dimension(ystart(1):yend(1),ystart(2):yend(2),ystart(3):yend(3)),intent(inout)::prsrc
    real(RK),dimension(mb1%xmm:mb1%xpm,mb1%ymm:mb1%ypm,mb1%zmm:mb1%zpm),intent(out)::prphiHalo

    ! locals
    integer::ic,jc,kc
    real(RK),dimension(xsize(1),xsize(2),xsize(3))::arrx1,arrx2
    real(RK),dimension(zsize(1),zsize(2),zsize(3))::arrz1,arrz2
    real(RK),dimension(ystart(1):yend(1),ystart(2):yend(2))::tridmj,tridcj,tridpj,tridfj

    call transpose_y_to_x(prsrc,arrx1)
    call dfftw_execute_r2r(fwd_plan_x,arrx1,arrx2)
    call transpose_x_to_z(arrx2,arrz1)
    call dfftw_execute_r2r(fwd_plan_z,arrz1,arrz2)
    call transpose_z_to_y(arrz2,prsrc)

    do jc=ystart(2),yend(2)
      do ic=ystart(1),yend(1)
        tridmj(ic,jc)=am2ph(jc)
        tridpj(ic,jc)=ap2ph(jc)
      enddo
    enddo
    IF(nrank==0) THEN
      do kc=2,yend(3)
        do jc=1,nyc
          do ic=1,yend(1)
            tridcj(ic,jc)=ac2ph(jc)+ak1(ic)+ak3(kc)
          enddo
        enddo
        call InverseTridiagonal(tridmj,tridcj,tridpj,prsrc(1:yend(1),1:nyc,kc),ysize(1),nyc)
      enddo

      ! for nrank=0, ystart(1)=ystart(3)=1
      ic=1; jc=1; kc=1;
      tridpj(ic,jc)=zero
      tridcj(ic,jc)=one
      tridmj(ic,jc)=zero
      tridfj(ic,jc)=zero
      do ic=2,yend(1)
        tridcj(ic,jc)=ac2ph(jc)+ak1(ic)+ak3(kc)
        tridfj(ic,jc)=prsrc(ic,jc,kc)
      enddo
      do jc=2,nyc
        do ic=1,yend(1)
          tridcj(ic,jc)=ac2ph(jc)+ak1(ic)+ak3(kc)
          tridfj(ic,jc)=prsrc(ic,jc,kc)
        enddo
      enddo
      call InverseTridiagonal(tridmj,tridcj,tridpj,tridfj,ysize(1),nyc)
      do jc=1,nyc
        do ic=1,yend(1)
          prsrc(ic,jc,kc)= tridfj(ic,jc)
        enddo
      enddo
    ELSE
      do kc=ystart(3),yend(3)
        do jc=ystart(2),yend(2)
          do ic=ystart(1),yend(1)
            tridcj(ic,jc)=ac2ph(jc)+ak1(ic)+ak3(kc)
          enddo
        enddo
        call InverseTridiagonal(tridmj,tridcj,tridpj,prsrc(ystart(1):yend(1),1:nyc,kc),ysize(1),nyc)
      enddo
    ENDIF
    call transpose_y_to_z(prsrc,arrz2)
    call dfftw_execute_r2r(bwd_plan_z,arrz2, arrz1)
    call transpose_z_to_x(arrz1,arrx2)
    call dfftw_execute_r2r(bwd_plan_x,arrx2, arrx1)
    call transpose_x_to_y(arrx1,prsrc)
    do kc=ystart(3),yend(3)
      do jc=ystart(2),yend(2)
        do ic=ystart(1),yend(1)
          prphiHalo(ic,jc,kc) = prsrc(ic,jc,kc)*normfft
        enddo
      enddo
    enddo
  end subroutine clcPPE

end module m_Poisson


C
C     ..................................................................
C
C        SUBROUTINE MINV
C
C        PURPOSE
C           INVERT A MATRIX
C
C        USAGE
C           CALL MINV(A,N,D,L,M)
C
C        DESCRIPTION OF PARAMETERS
C           A - INPUT MATRIX, DESTROYED IN COMPUTATION AND REPLACED BY
C               RESULTANT INVERSE.
C           N - ORDER OF MATRIX A
C           D - RESULTANT DETERMINANT
C           L - WORK VECTOR OF LENGTH N
C           M - WORK VECTOR OF LENGTH N
C
C        REMARKS
C           MATRIX A MUST BE A GENERAL MATRIX
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           THE STANDARD GAUSS-JORDAN METHOD IS USED. THE DETERMINANT
C           IS ALSO CALCULATED. A DETERMINANT OF ZERO INDICATES THAT
C           THE MATRIX IS SINGULAR.
C
C     ..................................................................
C
      SUBROUTINE MINV(A,N,D,L,M)
	IMPLICIT DOUBLE PRECISION (A-H)
	IMPLICIT DOUBLE PRECISION (O-Z)
      DIMENSION A(1),L(1),M(1)
C
C        ...............................................................
C
C        IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE
C        C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION
C        STATEMENT WHICH FOLLOWS.
C
C     DOUBLE PRECISION A,D,BIGA,HOLD,DABS
C
C        THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS
C        APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS
C        ROUTINE.
C
C        THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO
C        CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS.  ABS IN STATEMENT
C        10 MUST BE CHANGED TO DABS.
C
C        ...............................................................
C
C        SEARCH FOR LARGEST ELEMENT
C
      D=1.0
      NK=-N
      DO 80 K=1,N
      NK=NK+N
      L(K)=K
      M(K)=K
      KK=NK+K
      BIGA=A(KK)
      DO 20 J=K,N
      IZ=N*(J-1)
      DO 20 I=K,N
      IJ=IZ+I
   10 IF( DABS(BIGA)- DABS(A(IJ))) 15,20,20
   15 BIGA=A(IJ)
      L(K)=I
      M(K)=J
   20 CONTINUE
C
C        INTERCHANGE ROWS
C
      J=L(K)
      IF(J-K) 35,35,25
   25 KI=K-N
      DO 30 I=1,N
      KI=KI+N
      HOLD=-A(KI)
      JI=KI-K+J
      A(KI)=A(JI)
   30 A(JI) =HOLD
C
C        INTERCHANGE COLUMNS
C
   35 I=M(K)
      IF(I-K) 45,45,38
   38 JP=N*(I-1)
      DO 40 J=1,N
      JK=NK+J
      JI=JP+J
      HOLD=-A(JK)
      A(JK)=A(JI)
   40 A(JI) =HOLD
C
C        DIVIDE COLUMN BY MINUS PIVOT (VALUE OF PIVOT ELEMENT IS
C        CONTAINED IN BIGA)
C
   45 IF(BIGA) 48,46,48
   46 D=0.0
      RETURN
   48 DO 55 I=1,N
      IF(I-K) 50,55,50
   50 IK=NK+I
      A(IK)=A(IK)/(-BIGA)
   55 CONTINUE
C
C        REDUCE MATRIX
C
      DO 65 I=1,N
      IK=NK+I
      HOLD=A(IK)
      IJ=I-N
      DO 65 J=1,N
      IJ=IJ+N
      IF(I-K) 60,65,60
   60 IF(J-K) 62,65,62
   62 KJ=IJ-I+K
      A(IJ)=HOLD*A(KJ)+A(IJ)
   65 CONTINUE
C
C        DIVIDE ROW BY PIVOT
C
      KJ=K-N
      DO 75 J=1,N
      KJ=KJ+N
      IF(J-K) 70,75,70
   70 A(KJ)=A(KJ)/BIGA
   75 CONTINUE
C
C        PRODUCT OF PIVOTS
C
      D=D*BIGA
C
C        REPLACE PIVOT BY RECIPROCAL
C
      A(KK)=1.0/BIGA
   80 CONTINUE
C
C        FINAL ROW AND COLUMN INTERCHANGE
C
      K=N
  100 K=(K-1)
      IF(K) 150,150,105
  105 I=L(K)
      IF(I-K) 120,120,108
  108 JQ=N*(K-1)
      JR=N*(I-1)
      DO 110 J=1,N
      JK=JQ+J
      HOLD=A(JK)
      JI=JR+J
      A(JK)=-A(JI)
  110 A(JI) =HOLD
  120 J=M(K)
      IF(J-K) 100,100,125
  125 KI=K-N
      DO 130 I=1,N
      KI=KI+N
      HOLD=A(KI)
      JI=KI-K+J
      A(KI)=-A(JI)
  130 A(JI) =HOLD
      GO TO 100
  150 RETURN
      END


      SUBROUTINE fred2(n,a,b,t,f,w,g,ak)
      INTEGER n,NMAX
      REAL a,b,f(n),t(n),w(n),g,ak
      EXTERNAL ak,g
      PARAMETER (NMAX=200)
CU    USES ak,g,gauleg,lubksb,ludcmp
      INTEGER i,j,indx(NMAX)
      REAL d,omk(NMAX,NMAX)
      if(n.gt.NMAX) pause 'increase NMAX in fred2'
      call gauleg(a,b,t,w,n)
      do 12 i=1,n
        do 11 j=1,n
          if(i.eq.j)then
            omk(i,j)=1.
          else
            omk(i,j)=0.
          endif
          omk(i,j)=omk(i,j)-ak(t(i),t(j))*w(j)
11      continue
        f(i)=g(t(i))
12    continue
      call ludcmp(omk,n,NMAX,indx,d)
      call lubksb(omk,n,NMAX,indx,f)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/fred2.for


( syntaktista sokeria vektoreille )
: v3| immediate ;
: | immediate ;
: m| immediate ;

fvariable anglecos
fvariable anglesin

: fneg inline 0.0 fswap f- ;

: v3. -frot fswap ." v3| " f. space f. space f. ."  |" ;

: fpick ( n -- nthelement )
    fsp@ swap floatsize * + f@ ;

: m3.
    8 fpick f. space
    7 fpick f. space
    6 fpick f. cr
    5 fpick f. space
    4 fpick f. space
    3 fpick f. cr
    2 fpick f. space
    1 fpick f. space
    0 fpick f. cr

    9 times fdrop
;

: computeanglesincos inline
    fdup fsin anglesin f!
    fcos anglecos f!
;

: zrotmat ( angleinradians -- matrix )
    computeanglesincos

 m|  anglecos f@          anglesin f@   0.0  |
  |  anglesin f@ fneg     anglecos f@   0.0  |
  |  0.0                  0.0           1.0  |
;

: xrotmat ( angleinradians -- matrix )
    computeanglesincos

  m|  1.0    0.0                  0.0          |
   |  0.0    anglecos f@          anglesin f@  |
   |  0.0    anglesin f@ fneg     anglecos f@  |
;

: yrotmat ( angleinradians -- matrix )
    computeanglesincos

  m|  anglecos f@      0.0      anglesin f@ fneg  |
   |  0.0              1.0      0.0               |
   |  anglesin f@      0.0      anglecos f@       |
;

: identitymat ( -- matrix )
    m| 1.0  0.0  0.0 |
     | 0.0  1.0  0.0 |
     | 0.0  0.0  1.0 |
;

: normalize ( vector -- normalizedvector )
    fdupvec v3len^2 fsqrt v3s/
;


!  *********************************************************************
!  *                                                                   *
!  *                        subroutine corn2d                          *
!  *                                                                   *
!  *********************************************************************
!  Mixed Precision Version 2.21
!  Written by Gordon A. Fenton, TUNS, Aug. 26, 1992
!  Latest Update: Jun 9, 1999
!
!  PURPOSE  creates the parameter matrices required for the corner cell
!           subdivisions of LAS2G (and LAS3G special case).
!
!  Requires:
!   1) from libGAFsim:	DSIFA, DSISL, DCHOL2, DAXPY, DSWAP, DDOT, IDAMAX
!
!    n    is the rank of [CC][CC^T]. It can be either n = 3 for the 2-D case or
!         n = 7 for the 3-D case.
!    mc   is the mapping from the global covariance matrix `R' into the local
!         `corner' covariance matrix
!
!  REVISION HISTORY:
!  1.01	replaced dummy dimensions with a (*) for GNU's compiler (Jun 9/99)
!-----------------------------------------------------------------------------
      subroutine corn2d(R,ir,B,ib,S,is,CC,ic,n,AC,mc,iout,tol)
      real CC(ic,*), AC(4,n,*)
      real*8 R(ir,*), B(ib,*), S(is,*)
      real*8 RC(4,4), DA(4), BB(7,7)
      integer mc(4,*), indx(4)

   1  format(a,a,a)
   2  format(a,e13.4)
!							extract R
      do 10 j = 1, 4
         do 10 i = 1, j
            RC(i,j) = R(mc(i,1), mc(j,1))
  10  continue
!							factorize R
      call dsifa(RC,4,4,indx,ierr)
      if( ierr .ne. 0 ) then
         write(iout,1)'Error: unable to factorize corner covariance matrix in CORN2D.'
         stop
      endif
!							for each corner...
      do 70 nc = 1, 4
!							make a copy of S
         do 50 j = 1, n
            do 20 i = 1, 4
               DA(i) = S(mc(i,nc),j)
  20        continue
!							and solve for A
            call dsisl( RC, 4, 4, indx, DA )
!							store in real*4
            do 30 i = 1, 4
               AC(i,j,nc) = DA(i)
  30        continue
!							update B
            do 40 i = 1, j
               BB(i,j) = B(i,j)- S(mc(1,nc),i)*DA(1) - S(mc(2,nc),i)*DA(2) - S(mc(3,nc),i)*DA(3) - S(mc(4,nc),i)*DA(4)
  40        continue
  50     continue
!							Cholesky Decomposition
         call dchol2( BB, 7, n, rerr )
         if( rerr .gt. tol ) then
            write(iout,1)'Corn2d: Cholesky decomposition of corner covariance matrix BB'
            write(iout,2)'        has maximum relative error of ',rerr
         endif
!							store in real*4
         ii = 0
         do 60 j = 1, n
         do 60 i = 1, j
            ii = ii + 1
            CC(ii,nc) = BB(i,j)
  60     continue
  70  continue

      return
      end


!------------------------------------------------------------------------------
! Initialize:
! cnt for regular voxels of input array
! rest_cnt for fractions of the last cnt, which were not taken into account
!   for the subsequent new_voxel.
!------------------------------------------------------------------------------
rest_cnt(3)=0._rk
cnt(3) = 1_ik
!------------------------------------------------------------------------------
! Related to new dimensions (voxel)
!------------------------------------------------------------------------------
DO kk=1, new_dims(3)

    !------------------------------------------------------------------------------
    ! Related to new dimensions (mm)
    !------------------------------------------------------------------------------
    new_dims_real(3) = kk * target_spcng(3)

    !------------------------------------------------------------------------------
    ! Upper fraction of preceding new_voxel must be added to upcoming new_voxel.
    ! Must be done once and in front of loop.
    !------------------------------------------------------------------------------
    sum_new_vox = 0._rk

    ! DEVELOPMENT -----------------------------------------------------------------
    ! How to possibly get the arithmetic mean of floating point scaling.
    ! Postponed in the absence of compelling necessity.
    !------------------------------------------------------------------------------
    ! Z Direction:
    !------------------------------------------------------------------------------
    sum_new_vox = sum_new_vox + rest_cnt(3) * rry_ik2(cnt(1), cnt(2), cnt(3))

    DO WHILE(cnt(3) <= new_dims_real(3))
        sum_new_vox = sum_new_vox + rry_ik2(cnt(1), cnt(2), cnt(3))
        cnt(3) = cnt(3) + 1_ik
    END DO
    sum_new_vox = sum_new_vox + &
        (new_dims_real(3) - (cnt(3)-1_ik)) * rry_ik2(cnt(1)+1_ik, cnt(2)+1_ik, cnt(3)+1_ik)

    rest_cnt(3) = 1._rk - REAL(cnt(3)-1_ik, KIND=rk)
    !------------------------------------------------------------------------------
    ! to possibly get the arithmetic mean of floating point scaling.
    ! Postponed in the absence of compelling necessity.
    ! DEVELOPMENT -----------------------------------------------------------------

END  DO


!*****************************************************************************************
!> author: Jacob Williams
!
!  Basic orbital mechanics routines.

    module orbital_mechanics_module

    use kind_module
    use numbers_module
    use vector_module
    use math_module, only: wrap_angle

    implicit none

    private

    public :: rv_to_orbital_elements
    public :: orbital_elements_to_rv
    public :: orbit_period
    public :: orbit_energy
    public :: periapsis_apoapsis
    public :: sphere_of_influence
    public :: sphere_of_influence_earth_moon

    contains
!*****************************************************************************************

!*****************************************************************************************
!>
!  Convert position and velocity vectors to orbital elements.
!
!### See also
!  * The poliastro routine `rv2coe`.

    pure subroutine rv_to_orbital_elements(mu, r, v, p, ecc, inc, raan, aop, tru)

    implicit none

    real(wp),intent(in)              :: mu   !! gravitational parameter [\(km^{3}/s^{2}\)]
    real(wp),dimension(3),intent(in) :: r    !! position vector [km]
    real(wp),dimension(3),intent(in) :: v    !! velocity vector [km/s]
    real(wp),intent(out)             :: p    !! semiparameter \(a(1-e^{2})\) [km]
    real(wp),intent(out)             :: ecc  !! eccentricity [--]
    real(wp),intent(out)             :: inc  !! inclination [rad]
    real(wp),intent(out)             :: raan !! raan [rad]
    real(wp),intent(out)             :: aop  !! argument of peripsis [rad]
    real(wp),intent(out)             :: tru  !! true anomaly [rad]

    real(wp),dimension(3) :: h,n,e
    logical :: circular,equatorial
    reaL(wp) :: hmag,rmag,vmag

    rmag = norm2(r)
    vmag = norm2(v)
    h    = cross(r,v)
    hmag = norm2(h)
    n    = cross([zero,zero,one],h)/hmag
    e    = ((vmag**2-mu/rmag)*r-dot_product(r,v)*v)/mu
    ecc  = norm2(e)
    p    = hmag**2/mu
    inc  = atan2(norm2(h(1:2)),h(3))

    call orbit_check(ecc,inc,circular,equatorial)

    if (equatorial .and. .not. circular) then
        raan = zero
        aop  = wrap_angle(atan2(e(2),e(1))) ! Longitude of periapsis
        tru  = wrap_angle(atan2(dot_product(h,cross(e,r))/hmag,dot_product(r,e)))
    elseif ( .not. equatorial .and. circular) then
        raan = wrap_angle(atan2(n(2),n(1)))
        aop  = zero
        tru  = wrap_angle(atan2(dot_product(r,cross(h,n))/hmag,dot_product(r,n))) ! Argument of latitude
    elseif (equatorial .and. circular) then
        raan = zero
        aop  = zero
        tru  = wrap_angle(atan2(r(2),r(1))) ! True longitude
    else
        raan = wrap_angle(atan2(n(2),n(1)))
        aop  = wrap_angle(atan2(dot_product(e,cross(h,n))/hmag,dot_product(e,n)))
        tru  = wrap_angle(atan2(dot_product(r,cross(h,e))/hmag,dot_product(r,e)))
    endif

    end subroutine rv_to_orbital_elements
!*****************************************************************************************

!*****************************************************************************************
!>
!  Convert orbital elements to position and velocity vectors.

    pure subroutine orbital_elements_to_rv(mu, p, ecc, inc, raan, aop, tru, r, v)

    implicit none

    real(wp),intent(in)               :: mu   !! gravitational parameter [\(km^{3}/s^{2}\)]
    real(wp),intent(in)               :: p    !! semiparameter \(a(1-e^{2})\) [km]
    real(wp),intent(in)               :: ecc  !! eccentricity [--]
    real(wp),intent(in)               :: inc  !! inclination [rad]
    real(wp),intent(in)               :: raan !! raan [rad]
    real(wp),intent(in)               :: aop  !! argument of peripsis [rad]
    real(wp),intent(in)               :: tru  !! true anomaly [rad]
    real(wp),dimension(3),intent(out) :: r    !! position vector [km]
    real(wp),dimension(3),intent(out) :: v    !! velocity vector [km/s]

    real(wp),dimension(3,2) :: rotmat
    real(wp),dimension(2)   :: r_pqw,v_pqw
    logical                 :: circular,equatorial
    real(wp)                :: ctru,stru,sr,cr,si,ci,sa,ca,raan_tmp,aop_tmp

    call orbit_check(ecc,inc,circular,equatorial)

    if (circular) then   ! periapsis undefined
        aop_tmp = zero
    else
        aop_tmp = aop
    end if

    if (equatorial) then   ! node undefined
        raan_tmp = zero
    else
        raan_tmp = raan
    end if

    ! perifocal position and velocity:
    ctru   = cos(tru)
    stru   = sin(tru)
    r_pqw  = [ctru, stru] * p/(one+ecc*ctru)
    v_pqw  = [-stru, (ecc+ctru)] * sqrt(mu/p)

    ! perifocal to cartesian:
    sr          = sin(raan_tmp)
    cr          = cos(raan_tmp)
    si          = sin(inc)
    ci          = cos(inc)
    sa          = sin(aop_tmp)
    ca          = cos(aop_tmp)
    rotmat(1,:) = [cr*ca-sr*sa*ci, -cr*sa-sr*ca*ci]
    rotmat(2,:) = [sr*ca+cr*sa*ci, -sr*sa+cr*ca*ci]
    rotmat(3,:) = [sa*si, ca*si]

    ! transform:
    r = matmul(rotmat,r_pqw)
    v = matmul(rotmat,v_pqw)

    end subroutine orbital_elements_to_rv
!*****************************************************************************************

!*****************************************************************************************
!>
!  Check the orbit for singularities.

    pure subroutine orbit_check(ecc,inc,circular,equatorial)

    implicit none

    real(wp),intent(in) :: ecc        !! eccentricity
    real(wp),intent(in) :: inc        !! inclination [rad]
    logical,intent(out) :: circular   !! is the orbit circular?
    logical,intent(out) :: equatorial !! is the orbit equatorial?

    real(wp),parameter :: tol = 1.0e-10_wp !! tolerance for circular & equatorial checks

    circular   = ecc < tol
    equatorial = (one - abs(cos(inc))) < tol  ! 0 or 180 deg

    end subroutine orbit_check
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute the two-body orbital period.

    pure function orbit_period(mu,a) result(period)

    implicit none

    real(wp),intent(in) :: mu !! gravitational parameter [\(km^{3}/s^{2}\)]
    real(wp),intent(in) :: a  !! semimajor axis [km]
    real(wp) :: period        !! two-body orbital period [s]

    period = twopi/sqrt(mu/a**3)

    end function orbit_period
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute the two-body orbital energy.

    pure function orbit_energy(mu,rv) result(energy)

    implicit none

    real(wp),intent(in) :: mu               !! gravitational parameter [\(km^{3}/s^{2}\)]
    real(wp),dimension(6),intent(in) :: rv  !! position and velocity vector [km,km/s]
    real(wp) :: energy                      !! two-body orbital energy [\(km^{2}/s^{2}\)]

    real(wp) :: rmag  !! position vector magnitude [km]
    real(wp) :: vmag  !! velocity vector magnitude [km]

    rmag = norm2(rv(1:3))
    vmag = norm2(rv(4:6))

    energy = (vmag**2 / two) - (mu / rmag)

    end function orbit_energy
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute the periapsis and apoapsis position and velocity magnitudes.

    pure subroutine periapsis_apoapsis(mu,a,e,rp,ra,vp,va)

    implicit none

    real(wp),intent(in)  :: mu  !! gravitational parameter [\(km^{3}/s^{2}\)]
    real(wp),intent(in)  :: a   !! semimajor axis [km]
    real(wp),intent(in)  :: e   !! eccentricity [--]
    real(wp),intent(out) :: rp  !! periapsis position magnitude [km]
    real(wp),intent(out) :: ra  !! apoapsis position magnitude [km]
    real(wp),intent(out) :: vp  !! periapsis velocity magnitude [km/s]
    real(wp),intent(out) :: va  !! apoapsis velocity magnitude [km/s]

    real(wp) :: rarp   !! \(r_a + r_p \)
    real(wp) :: twomu  !! \( 2 \mu \)

    twomu = two * mu

    rp   = a*(one-e)
    ra   = a*(one+e)
    rarp = ra + rp
    vp   = sqrt(twomu*ra/(rp*rarp))
    va   = sqrt(twomu*rp/(ra*rarp))

    end subroutine periapsis_apoapsis
!*****************************************************************************************

!*****************************************************************************************
!>
!  Computes the sphere-of-influence radius of the secondary body.
!
!### See also
!  * R.H. Battin, "An Introduction to the Mathematics and
!    Methods of Astrodynamics, Revised Edition", AIAA, 1999.
!  * This is the approximate formula (8.74 from Battin).

    pure function sphere_of_influence(mu_primary, mu_secondary, r_ps) result(r_soi)

    implicit none

    real(wp),intent(in)   :: mu_primary   !! primary body gravitational parameter [km^3/s^2]
    real(wp),intent(in)   :: mu_secondary !! secondary body gravitational parameter [km^3/s^2]
    real(wp),intent(in)   :: r_ps         !! distance between the two bodies [km]
    real(wp)              :: r_soi        !! sphere of influence radius [km]

    real(wp),parameter :: two_fifths = two/five

    if (mu_primary>zero .and. mu_secondary>zero .and. r_ps>zero) then
        r_soi = r_ps * (mu_secondary/mu_primary)**two_fifths
    else
        r_soi = zero
    end if

    end function sphere_of_influence
!*****************************************************************************************

!*****************************************************************************************
!>
!  Computes the sphere-of-influence radius of the secondary body.
!
!### Notes
!  * `r` and `r_sp` should be in the same inertial frame.
!  * The mass of the spacecraft is neglected.
!
!### See also
!  * R.H. Battin, "An Introduction to the Mathematics and
!    Methods of Astrodynamics, Revised Edition", AIAA, 1999.
!  * This is the more complex formula, on p. 397 of Battin,
!    which is better for the Earth/Moon system.

    pure function sphere_of_influence_earth_moon(mu_primary, mu_secondary, r, r_sp) result(r_soi)

    implicit none

    real(wp),intent(in)              :: mu_primary   !! primary body gravitational parameter [km^3/s^2]
    real(wp),intent(in)              :: mu_secondary !! secondary body gravitational parameter [km^3/s^2]
    real(wp),dimension(3),intent(in) :: r            !! vector from the secondary body to the spacecraft [km]
    real(wp),dimension(3),intent(in) :: r_sp         !! vector from the secondary to the primary body [km]
    real(wp)                         :: r_soi        !! sphere of influence radius of the secondary body [km]

    real(wp) :: r_mag, r_sp_mag, alpha, ca, ca2, denom

    r_mag    = norm2(r)
    r_sp_mag = norm2(r_sp)

    if (mu_primary>zero .and. mu_secondary>zero .and. r_mag>zero .and. r_sp_mag>zero) then

        alpha = angle_between_vectors(r,r_sp)
        ca    = cos(alpha)
        ca2   = ca * ca

        denom = (mu_secondary**2/mu_primary**2)**(one/five)*(one+three*ca2)**(one/ten) + &
                (two/five)*ca*((one+six*ca2)/(one+three*ca2))

        r_soi = r_sp_mag / denom

    else
        r_soi = zero
    end if

    end function sphere_of_influence_earth_moon
!*****************************************************************************************

!*****************************************************************************************
    end module orbital_mechanics_module
!*****************************************************************************************


        program s_pscorg
*******************************************************************************
*
* s_pscorg is a phase screen simulator which produces artificial fringe
* or speckle patterns and obtain integrated power spectrum or(/and)
* optionally specified bispectral components.
*
* The atmospheric disturbance is given by the Kolmogorov spectrum.
* Seeing condition, aperture configuration and the object ( at this
* point, only multiple point sources ) and the usage of the phase screen
* must be specified by the user in an ascii input file.
*
* Following is a sample input file. (free format, ! indicates a
* comment line.)
*
* ! Field of view: side of image in arcseconds
* Field of view
* 12
* ! seed for random number generator (large odd integer)
* Random
* 7597551
* ! outer scale, inner scale of the turbulence(m) - recommended values
* Turbulence scale
* 10.0  0.01
* ! Fried radius (r_zero) in m
* Fried
* 0.1
* ! central wavelength(m), fractional bandwidth, sampling points
* Wavelength
* 0.65e-6 0.016 3
* ! source: # of point sources
* !         intensity(arbitrary unit), position offset(x,y) in arcsecond
* Source
* 2
* 1.0  -0.7 -0.6
* 0.5   0.8 0.4
* ! # of circular apertures (including voids)
* ! configuraton: center of aperture(x,y), radius(m) and type
* ! 1 is an aperture,0 is a void. Voids should follow ordinary apertures.
* ! Example: annular mask
* Aperture
* 2
* 0.0 0.0 2.0  1
* 0.0 0.0 1.9  0
* ! Multiple subsets are taken out of one phase screen.
* ! Equally spaced sampling is specified by
* ! x_min, x_max, step size in x(m)
* ! y_min, y_max, step size in y(m)
* ! JLP/WARNING: x_min, y_min should be larger than the aperture radii !!!
* Phase_screen
* 1.25 8.75  0.14
* 1.25 8.75  2.5
* ! total number of frames to be processed
* Frames
* 100
* ------ as an option `no atmosphere' can be specified by ------
* ! obtaining beam pattern
* No_disturbance
* --------------------------------------------------------------
*
* This is a re-organized version of the pscsn.for developed on Tacos.
* The program is planned to be as users oriented as possible for the
* future development of Optical/IR interferometry.
*
* version 1.0    Dec 25, 1988 (Merry Christmas!)     Tadashi Nakajima
* Today's resolution : `I will have real holidays next year and live
*                       a human life.'
* version 2.0    Dec 30, 1988   Now sharp cut-offs of fluctuation power
* spectrum at kapmin and kapmax are introduced to investigatate the
* relative significance of the diffractive effect and refractive effect.
* For instance, the refractive effect can be seen by setting lo = 0.1,
* while the diffractive effect can be investigated by setting L0 = 0.4.
*
* JLP:
*   - I introduce fourn1 and jlp_random
*   - I remove the common blocks, split the program into subroutines
*      and complete the documentation
*   - AND I CORRECT DEEPLY THIS PROGRAM SINCE IT RELIED ON AN UNKNOWN
*      STRUCTURE OF FOURIER COMPLEX ARRAYS AND FOURIER TRANSFORM!
*   - I add r_zero and field of view into the parameter file
*   - I change the screen generator (jlp_phase_screen) so that the
*   simulation is compatible with the r_zero value (the old version was not)
*   - I replace the pseudo-convolution of the objet with the PSF by a true
*   convolution
*   - I implement a good formula for the image smearing due to finite bandwidth
*   (the original was wrong!)
*
* JLP
* Version 26/05/2008
*******************************************************************************
*------ declarations ---------*
        implicit none
* Constants
        real*4 pi

* Integrated structure constant of the phase fluctuation
* LCn2 = \int Cn2(h) dh
* And also:
* r_0 = (0.423 kk^2 LCn2)^{-3/5}
        real*4 LCn2, r_zero

* Size of phase screen and resolution (m/pix)
        real*4 Ls, Lp

* Size of phase screen, size of power spectrum
        integer*4 Ns, Np
        parameter(Ns = 512)
        parameter(Np = Ns/2)

* Wave number, scale length of turbulence
* fov: field of view (for the simulated images)
        real kk, L0, lambda, lo, fov

* psc: complex phase screen, real and imag are independent.
* FT_object(Np,Np): Fourier Transform of the object
        complex psc(Ns,Ns), FT_object(Np,Np)

* Power spectrum array
        real*4 pwr(Np,Np)

* Input control parameter file and output power spectrum file
        character ifile*60, ofile*60, ocomments*80

* I/O units
        integer*4 f_out
        parameter(f_out = 12)

* nframes: number of frames
* nscreens: number of phase screens
* frm_per_scr: number of frames per phase screen
        integer*4  nframes, nscreens, frm_per_scr

* Maxcomp: maximum number of components in source
* Maxap: maximum number of apertures
        integer*4 Maxcomp, Maxap
        parameter(Maxcomp = 50, Maxap = 15)

* Source information (intensity and position in arcsec)
        real*4 s_int(Maxcomp), s_pos(Maxcomp,2), object(Np,Np)

* Aperture information (coordinate, radius, type)
        real*4 c_pos(Maxap,2), c_rad(Maxap)
        integer*4 c_typ(Maxap)
* Miscellaneous:
        real*4 zero, x_min, x_max, xstep, y_min, y_max, ystep
        real*4 rapsec, fractional_bw
        integer*4 ncalls, ncircle, nsamp, lx, ly, i, iz, jz, iframe
        integer*4 ncomp, seed, no_dist

* Initialization of variables:
        pi = 3.141592653

* rapsec: radians per arcsecond
        rapsec = pi/(180. * 3600.0)

* JLP
* Program can then be run as "runs s_pscorg s_screen.input power"
        call jlp_begin
        call jlp_inquifmt

* Input file names (from terminal or "jlp_lu5.tmp" file when run with "runs")
        write(6,10)
   10   format(1x,'Input ascii file name : ',$)
        read(5,'(a)') ifile
        write(6,20)
   20   format(1x,'Output power FITS file name : ',$)
        read(5,'(a)') ofile
        write(6,25)
   25   format(1x)

C Read input parameter file:
        call read_input_file(ifile, seed, L0, lo, lambda, fractional_bw,
     1                nsamp, ncomp, s_int, s_pos, ncircle, c_pos,
     1                c_rad, c_typ, x_min, x_max, xstep, y_min,
     1                y_max, ystep, fov, r_zero, nframes, no_dist,
     1                Maxcomp, Maxap)

C Initialization of random generator:
        call jlp_random_init(seed)

*  kk: wave number
        kk = 2.0 * pi / lambda

* Original version with LCn2 = 5.0e-13
* r_0 = (0.423 kk^2 LCn2)^{-3/5}
        LCn2 = (r_zero**(3./5.)) / (0.423 * kk * kk)
        write(6,287) lambda, r_zero, LCn2
287     format('lambda=',e12.5,' r_zero=',f8.3,' LCn2=',e12.5)

* Scale of image in pixels/arcsecond: Scale = (Ls/lambda)*(Np/Ns)*rapsec
* Field of view = Np/Scale
* Size of phase screen and resolution (m/pix)
        Ls = Ns / ((fov / lambda) * rapsec)
        write(6,*) 'Size of pupil: Ls = ',Ls,' m'
        Lp = Ls / real(Ns)
        write(6,*) 'Resolution of pupil: Lp = ',Lp,' m'

C Create an image of the source from ncomp, s_int, s_pos
         call create_object(object, FT_object, Np, Ns, ncomp,
     1              s_int, s_pos, Ls, lambda, Maxcomp)

* Number of frames per phase screen
        frm_per_scr =
     1  (int((x_max-x_min)/xstep)+1)*(int((y_max-y_min)/ystep)+1)
*
        if( mod(nframes,frm_per_scr) .eq. 0 ) then
          nscreens = nframes / frm_per_scr
        else
          nscreens = nframes / frm_per_scr + 1
        end if

        do iz=1,Np
        do jz=1,Np
          pwr(jz,jz) = 0.
        end do
        end do
* Two real phase screens per complex random number generation in Fourier
* domain.

        if( mod(nscreens,2) .eq. 0 ) then
          ncalls = nscreens/2
        else
          ncalls = nscreens/2 + 1
        end if
        write(6,*)' ******** Will now simulate ', nframes,
     1            ' elementary frames ************'
        write(6,*)' Number of frames per phase screen: ', frm_per_scr
        write(6,*)' Number of phase screen needed: ', nscreens
        write(6,*)' Number of calls of phase_screen routine needed: ',
     1            ncalls

        iframe = 0
        do 300 i = 1, ncalls
*------------------------------------
        if (no_dist.eq.1) then
* no atmospheric disturbance
        write(6,312) i, iframe+1
  312   format('+', 'generating ',i3,
     1         'th zero phase screen (iframe=',i3,')')
          do iz=1, Ns
            do jz=1, Ns
              psc(iz,jz) = (0.0,0.0)
            end do
          end do
        else
* Create a complex phase screen
        write(6,310) i, iframe+1
  310   format('+', 'generating ',i3,
     1         'th complex phase screen (iframe=',i3,')')
C New version:
        call jlp_phase_screen(psc, Ns, seed, L0, r_zero)
C Old version:
C        call  phase_screen(psc, Ns, seed, Ls, L0, lo,
C     1                     kk, LCn2)
        end if

* sample phase screen, form images, calculate power
        call  power(psc, Ns, FT_object, pwr, Np, iframe, nframes, Ls,
     1                  lambda, fractional_bw, nsamp, ncomp,
     1                  s_int, s_pos, ncircle, c_pos, c_rad, c_typ,
     1                  x_min, x_max, xstep, y_min, y_max, ystep,
     1                  Maxcomp, Maxap)

          if(iframe .ge. nframes) goto 400
*
*------------------------------------
* End of loop
  300   continue
*

* Exit from loop
  400   continue

        call jlp_recent_real(pwr, Np)
* Normalize integrated power spectrum
        zero = pwr(Np/2+1,Np/2+1)
        do lx=1, Np
          do ly=1, Np
            pwr(lx,ly) = pwr(lx,ly)/zero
          end do
        end do

* Create a FITS file
        write(6,*)' Writing output file:',ofile
        write(ocomments,88)ifile,char(0)
88      format('From ',A,A)
        call jlp_writeimag(pwr,Np,Np,Np,ofile,ocomments)
*
        call jlp_end
        stop
        end
***************************************************************************
* Creates complex phase screen (JLP's version)
*
* INPUT:
* Ns: size of phase screen (512)
* seed: seed for the random number generator,
*
* OUPUT:
*
***************************************************************************
        subroutine jlp_phase_screen(psc, Ns, seed, L0, r_zero)
        implicit none
        integer*4 Ns, seed
        complex psc(Ns,Ns),iiu
        real*4 L0, r_zero, pi, work(Ns,Ns), mean, sigma
        real*4 rad2
        real*8 sum, sumsq
        logical debug
        character out_file*60, out_comments*80
        real*4 urad, radi, Fs, Fs0, utheta

* N(): dimension array for fft
* Ns_cent: origin of the phase screen
        integer*4 N(2), Ns_cent, jx, jy, i, j

        debug=.true.
* Constants:
* iiu = sqrt(-1) or "i"
        iiu = (0.0,1.0)
        pi = 3.141592653

* r_0 = (0.423 kk^2 LCn2)^{-3/5}
* Hence Fs0 is proportional to kk^2
C JLP2008 / I put Ns^4 instead of Ns^2 ...
        Fs0 = 0.023 * Ns * Ns * Ns * Ns * (L0 / r_zero)**(5./3.)

*------ generation of random phase in spatial domain -------------
* Complex Gaussian random numbers are generated by
* the inverse transform method.

        N(1) = Ns
        N(2) = Ns
        Ns_cent = Ns/2+1

        do 100 jx=1, Ns
          do 110 jy=1, Ns

            rad2=(jx-Ns_cent)*(jx-Ns_cent)+(jy-Ns_cent)*(Jy-Ns_cent)

* rad**(-11/3) is undefined at rad2=0.
            if(rad2 .eq. 0.0) rad2 = 0.5

10          call jlp_random(urad)
            if ( urad.gt.0.0 ) then
              radi = sqrt(-2.0*log(urad))
            else
              goto 10
            end if
            Fs = Fs0 * rad2**(-11.0/6.0)
            call jlp_random(utheta)
* iiu = sqrt(-1) or "i"
* Hence psc is proportional to kk = 2 pi / lambda
            psc(jx,jy) = sqrt(Fs)*radi*cexp(iiu*2.0*pi*utheta)
  110     continue
  100   continue

*---------- Fourier transform ------------------------------
* Shift origin of Fourier space to (0,0) before inverse Fourier transform
* Old recentering version from original program was wrong!
        call jlp_recent_cmplx(psc, Ns)

        write(6,555) N(1),N(2)
  555   format('+', 'start ',i3,'x',i3,' sized fft              ')
C        call fourn1(psc,N,2,-1,+1)
C JLP2008 (by comparing with s_psc.for):
C fourn1(data,nn,ndim,isign)
C SHOULD USE MY fourn1 routine (in fft_jlp.for)
C NOT s_fourn1.for !!!
        call fourn1(psc,N,2,-1)
        write(6,666)
  666   format('+', 'end fft for screen                         ')

* Now psc is a complex random phase screen
* to avoid discontinuity shift origin of phase screen to (Ns/2,Ns/2)
* Old recentering version from original program was wrong!
        call jlp_recent_cmplx(psc, Ns)

C Output phase screen:
        if(debug)then
          sum = 0.
          sumsq = 0.
          do i=1, Ns
            do j=1, Ns
              work(i, j) = real(psc(i,j))
              sum = sum + work(i,j)
              sumsq = sumsq + work(i,j) * work(i,j)
            end do
          end do
          mean = sum / real(Ns * Ns)
          sigma = sqrt(sumsq / real(Ns * Ns) - mean * mean)
          write(6,*)'Phase screen: mean=', mean,' sigma=',sigma
          out_file='screen_real_psc'
          out_comments='Real part of phase screen'
          call jlp_writeimag(work,Ns,Ns,Ns,out_file,out_comments)
        endif

        return
        end
***************************************************************************
* Creates complex phase screen (original version)
*
* INPUT:
* Ns: size of phase screen (512)
* seed: seed for the random number generator,
* kk: wave number
* LCn2 integrated CN2 over all the altitudes (originally: LCn2=5.0e-13)
*
* OUPUT:
*
***************************************************************************
        subroutine phase_screen(psc, Ns, seed, Ls, L0, lo,
     1                          kk, LCn2)
        implicit none
        integer*4 Ns, seed
        complex psc(Ns,Ns),iiu
        real*4 dkap, kapmin, kapmax, kk, LCn2, pi, Ls, L0, lo, Lp
        real*4 work(Ns,Ns), mean, sigma, ww
        real*8 sum,sumsq
        logical debug
        character out_file*60, out_comments*80

* kap: radial spatial frequency in aperture plane ( * 2 pi / L)
        real*4 kap, atten, urad, radi, Fs, Fs0, utheta

* N(): dimension array for fft
* Ns_cent: origin of the phase screen
        integer*4 N(2), Ns_cent, jx, jy, i, j

        debug=.true.
* Constants:
* iiu = sqrt(-1) or "i"
        iiu = (0.0,1.0)
        pi = 3.141592653

* Lp: pixel scale of phase screen
        Lp = Ls/Ns

* kapmin, kapmax: min and max spatial frequencies in aperture plane
* Ls: size of phase screen (in m)
* Lp: resolution, i.e., size of one pixel in pupil (in m/pix)
        if (Ls .lt. L0) then
          kapmin = 2.0 * pi / Ls
        else
          kapmin = 2.0 * pi / L0
        end if

        if (lo .lt. Lp) then
           kapmax = 2.0 * pi / Lp
        else
           kapmax = 2.0 * pi / lo
        end if

* dkap: one pixel in spatial frequency in aperture plane (dkap = 2 pi / Ls)
        dkap = 2.0 * pi / Ls

* dkap: one pixel in spatial frequency in aperture plane (dkap = 2 pi / Ls)
* r_0 = (0.423 kk^2 LCn2)^{-3/5}
        Fs0 = 0.033*pi*LCn2*kk*kk*2.0*dkap*dkap

*------ generation of random phase in spatial domain -------------
* Complex Gaussian random numbers are generated by
* the inverse transform method.

        N(1) = Ns
        N(2) = Ns
        Ns_cent = Ns/2+1

        do 100 jx=1, Ns
          do 110 jy=1, Ns

            kap = dkap*sqrt( float( (jx-Ns_cent)**2+(jy-Ns_cent)**2 ) )

* Introducing smooth cut-offs below kapmin and beyond kapmax.

            if(kap .gt. kapmax) atten = exp(-(kap-kapmax)/(5.0*dkap))
            if(kap .lt. kapmin) atten = exp(-(kapmin-kap)/(5.0*dkap))
            if(kap.le.kapmax .and. kap.ge.kapmin) atten = 1.0

* kap**(-11/3) is undefined at kap=0.
            if(kap .eq. 0.0) kap = dkap

10          call jlp_random(urad)
            if ( urad.gt.0.0 ) then
              radi = sqrt(-2.0*log(urad))
            else
              goto 10
            end if
* Fs0 = 0.033*pi*LCn2*k*k*2.0*dkap*dkap
* Fs = 0.033*pi*LCn2*kk*kk*2.0*kap**(-11.0/3.0)*dkap*dkap
            Fs = Fs0 * kap**(-11.0/3.0)
            call jlp_random(utheta)
* iiu = sqrt(-1) or "i"
            psc(jx,jy) = atten*sqrt(Fs)*radi*cexp(iiu*2.0*pi*utheta)
  110     continue
  100   continue

*---------- Fourier transform ------------------------------
* Shift origin of Fourier space to (0,0)
* Old recentering version from original program was wrong!
        call jlp_recent_cmplx(psc, Ns)

        write(6,555) N(1),N(2)
  555   format('+', 'start ',i3,'x',i3,' sized fft              ')
C        call fourn1(psc,N,2,-1,+1)
C JLP2008 (by comparing with s_psc.for):
C fourn1(data,nn,ndim,isign)
C SHOULD USE MY fourn1 routine (in fft_jlp.for)
C NOT s_fourn1.for !!!
        call fourn1(psc,N,2,-1)
        write(6,666)
  666   format('+', 'end fft for screen                         ')

C JLP2008: I multiply with Ns*Ns, since otherwise
C the values of psc are much too small!
        ww = real(Ns * Ns)
          do i=1, Ns
            do j=1, Ns
              psc(i,j) = psc(i,j) * ww
            end do
          end do

* Now psc is a complex random phase screen
* to avoid discontinuity shift origin of phase screen to (Ns/2,Ns/2)
* Old recentering version from original program was wrong!
        call jlp_recent_cmplx(psc, Ns)

C Output phase screen:
        if(debug)then
          sum = 0.
          sumsq = 0.
          do i=1, Ns
            do j=1, Ns
              work(i, j) = real(psc(i,j))
              sum = sum + work(i,j)
              sumsq = sumsq + work(i,j) * work(i,j)
            end do
          end do
          mean = sum / real(Ns * Ns)
          sigma = sqrt(sumsq / real(Ns * Ns) - mean * mean)
          write(6,*)'Phase screen: mean=', mean,' sigma=',sigma
          out_file='screen_real_psc'
          out_comments='Real part of phase screen'
          call jlp_writeimag(work,Ns,Ns,Ns,out_file,out_comments)
        endif

        return
        end
*******************************************************************************
* power
* Produces fringe/speckle patterns of multiple point sources.
* Finite bandwidth effect is taken into account.
*
* INPUT:
* psc(Ns,Ns): phase screen
* Ns: size of phase screen (=512)
* Np: size of power spectrum (=Ns/2)
* iframe: index of current frame to be processed
* nframes: number of frames to be simulated
* ncomp: number of components for the source
* s_int, s_pos: source information (intensity and position in arcsec)
* ncirc: number of circles for the aperture
* c_pos, c_rad, c_typ: aperture information (coordinate, radius, type)
* Ls: size of phase screen (in m)
* lambda, fractional_bw, nsamp: Wavelength parameters: central wavel.,
*                          fractional bandwidth and sampling points
* x_min, x_max, xstep : sampling parameters to extract a phase screen
*                       from a larger one
* y_min, y_max, ystep : sampling parameters to extract a phase screen
*                       from a larger one
* Maxcomp: maximum number of components in source
* Maxap: maximum number of apertures
*
* OUTPUT:
* pwr(Np,Np): power spectrum
*******************************************************************************
        subroutine power(psc, Ns, FT_object, pwr, Np, iframe,
     1                  nframes, Ls,
     1                  lambda, fractional_bw, nsamp, ncomp,
     1                  s_int, s_pos, ncircle, c_pos, c_rad, c_typ,
     1                  x_min, x_max, xstep, y_min, y_max, ystep,
     1                  Maxcomp, Maxap)
        implicit none
        integer Ns, Np, Maxcomp, Maxap
        complex psc(Ns,Ns), FT_object(Np,Np)
        real*4 pwr(Np,Np), Ls, lambda, fractional_bw
        real*4 x_min, x_max, xstep, y_min, y_max, ystep
        integer*4 iframe, nframes, nsamp, ncomp, ncircle

* Aperture information (coordinate, radius, type)
        real*4 c_pos(Maxap,2), c_rad(Maxap)
        integer*4 c_typ(Maxap)

* Source information (intensity and position in arcsec)
        real*4 s_int(Maxcomp), s_pos(Maxcomp,2)

* Temporary arrays
        real*4  PSF1(Np,Np), PSF2(Np,Np)

C Miscellaneous:
        integer*4 N(2), Np_cent
        integer*4 output_screen
        real*4  Lp, Scale, x, y

* Constants
        real*4 pi, rapdeg, rapsec
        complex iiu
* iiu = sqrt(-1) or "i"
        iiu = (0.0,1.0)
        pi = 3.141592653

* rapsec: radians per arcsecond
        rapdeg = pi/180.0
        rapsec = rapdeg/3600.0

        output_screen = 0
        N(1) = Np
        N(2) = Np
* Ls: size of phase screen (in m)
* Lp: pixel scale of phase screen
        Lp = Ls/Ns
        Np_cent = Np/2+1
* lambda: wavelength (in meters)
* Scale: in pixels/arcsecond
        Scale = (Ls/lambda)*(real(Np)/real(Ns))*rapsec

* Setting apertures on Np sized window in Ns sized complex phase screen

        do 110 x=x_min,x_max,xstep
        do 120 y=y_min,y_max,ystep
**************************** major loop ***************************************

        write(6,111) x,y
  111   format('+',' creating a pair of speckle/fringe patterns at',
     1         'x=',f10.3,' y=',f10.3)

        write(6,333) ncircle, nsamp, c_typ(1), c_typ(2)
  333   format(1x,'ncircle nsamp typ(1) typ(2) ',1x,4(i2,1x) )

C Compute two elementary PSFs (PSF1 and PSF2)
        call compute_elementary_PSFs(psc, x, y, Ls,
     1                  lambda, fractional_bw, nsamp,
     1                  ncircle, c_pos, c_rad, c_typ,
     1                  PSF1, PSF2, Ns, Np, Maxap, output_screen)

C Convolution of the object with the elementary PSFs

        write(6,320) iframe+1
  320   format('+', 'processing ',i5,' th frame                    ')
       call process_elementary_image(pwr, PSF1, FT_object,
     1                      Np, output_screen)
        iframe = iframe + 1
        if( iframe .ge. nframes) return

        write(6,320) iframe+1
       call process_elementary_image(pwr, PSF2, FT_object,
     1                      Np, output_screen)
        iframe = iframe + 1
        if( iframe .ge. nframes) return

************************* end of major loop ***********************************
  120   continue
  110   continue

        return
        end
***************************************************************************
* read_input_file: read input parameter file
*
* INPUT:
* ifile: name of input parameter file
*
* OUTPUT:
* seed: seed for random number generator (large odd integer)
* L0, lo: external and internal scale lengths of turbulence
* lambda, fractional_bw, nsamp: Wavelength parameters: central wavel.,
*                          fractional bandwidth and sampling points
* x_min, x_max, xstep : sampling parameters to extract a phase screen
*                       from a larger one
* y_min, y_max, ystep : sampling parameters to extract a phase screen
*                       from a larger one
* ncomp: number of components for the source
* s_int, s_pos: source information (intensity and position in arcsec)
* ncirc: number of circles for the aperture
* c_pos, c_rad, c_typ: aperture information (coordinate, radius, type)
* fov: field of view (in arcseconds)
* nframes: number of frames to be simulated
* no_dist: flag set to one if no atmospheric disturbance
* Maxcomp: maximum number of components in source
* Maxap: maximum number of apertures
*
***************************************************************************
        subroutine read_input_file(ifile, seed, L0, lo,
     1                  lambda, fractional_bw, nsamp, ncomp,
     1                  s_int, s_pos, ncircle, c_pos, c_rad, c_typ,
     1                  x_min, x_max, xstep, y_min, y_max, ystep,
     1                  fov, r_zero, nframes, no_dist, Maxcomp, Maxap)
        implicit none
        integer*4 Maxcomp, Maxap
        character ifile*60, comment*80
        real*4 L0, lo, lambda, fractional_bw
        real*4 s_int(Maxcomp), s_pos(Maxcomp,2)
        real*4 c_pos(Maxap,2), c_rad(Maxap)
        real*4 x_min, x_max, xstep, y_min, y_max, ystep, fov, r_zero
        integer*4 seed, nsamp, ncomp, ncircle, nframes, no_dist
        integer*4 c_typ(Maxap), j, n
* I/O units
        integer*4 f_in
        parameter(f_in = 11)

* Initialize no_dist to default value:
        no_dist = 0

* Read the input file
        open(unit=f_in, file=ifile, status='old')

   30   format(a80)
        do 40 j=1,100

          read(f_in,30,end=100) comment
          if( comment(1:1) .eq. '!') goto 40

          write(6,30) comment

C Keyword "Field of view", parameter: fov
          if(comment(1:5) .eq. 'Field')then
            read(f_in,*) fov
            write(6,*) 'OK: fov=',fov,' arcseconds'
C Keyword "Random", parameter: seed (random generator):
          else if(comment(1:6) .eq. 'Random')then
            read(f_in,*) seed
            write(6,*) 'OK: seed=',seed
C Keyword "Turbulence scale", parameters: outer and inner  scales
          else if(comment(1:10) .eq. 'Turbulence')then
            read(f_in,*) L0, lo
            write(6,*) 'OK: L0=',L0,' lo=',lo
C Keyword "Fried radius", parameters: outer and inner  scales
          else if(comment(1:5) .eq. 'Fried')then
            read(f_in,*) r_zero
            write(6,*) 'OK: r0=',r_zero
C Keyword "Wavelength", parameters: central wavel., fractional bandwidth,
C sampling points
C lambda: wavelength (in meters)
C Fractional bandwidth = 2 (Fh - Fl)/(Fh + Fl)
C where Fh is the highest frequency limit with signal 10dB below peak emission
C where Fl is the lowest frequency limit with signal 10dB below peak emission
          else if(comment(1:10) .eq. 'Wavelength')then
            read(f_in,*) lambda, fractional_bw, nsamp
            write(6,*) 'OK: lambda=',lambda,
     1           'm  fractional_bw=',fractional_bw,' nsamp=', nsamp,
     1           '(hence bandwidth =',fractional_bw * lambda,' m)'
C Keyword "Source", parameters: number of points, followed by
C Intensity1, X1, Y1
C Intensity2, X2, Y2...
          else if(comment(1:6) .eq. 'Source')then
            read(f_in,*) ncomp
            write(6,*) 'OK: Source with ',ncomp,' components'
            do n=1,ncomp
              read(f_in,*) s_int(n),s_pos(n,1),s_pos(n,2)
              write(6,*)' int, x, y: ',s_int(n),s_pos(n,1),s_pos(n,2)
            end do
C Keyword "Aperture", parameters: number of apertures, followed by
C Xcenter, Ycenter, radius, type (0 or 1)
          else if(comment(1:8) .eq. 'Aperture')then
            read(f_in,*) ncircle
            write(6,*) 'OK: Aperture with ',ncircle,' circles'
            do n=1,ncircle
              read(f_in,*) c_pos(n,1),c_pos(n,2),c_rad(n),c_typ(n)
              write(6,*)' x, y, rad, type: ',
     1                    c_pos(n,1),c_pos(n,2),c_rad(n),c_typ(n)
            end do
C Keyword "Phase screen", parameters: x_min, x_max, step
          else if(comment(1:5) .eq. 'Phase')then
            read(f_in,*) x_min, x_max, xstep
            read(f_in,*) y_min, y_max, ystep
            write(6,*) 'OK: xmin, xmax, xstep:', x_min, x_max, xstep
            write(6,*) 'OK: ymin, ymax, ystep:', y_min, y_max, ystep
C Keyword "Frame", parameters: nber of frames
          else if(comment(1:6) .eq. 'Frames')then
            read(f_in,*) nframes
            write(6,*) 'OK: nframes=',nframes
C Keyword "No disturbance" (no atmosphere)
          else if( comment(1:2) .eq. 'No') then
            no_dist = 1
            write(6,*) 'OK: no atmospheric disturbance'
          end if
C EOF loop
   40   continue

C Switch to label=100 in case of end of file:
  100   close(unit=f_in)
        return
        end
*****************************************************************
* Recenter Fourier transform
* and shift origin from (0,0) to (Ns/2+1, Ns/2+1) or inversely
*
* Old recentering version from original program was not compatible
* with "fourn1" (and relative to an unknown data structure)
*
* Quadrants
*     3 4        2 1
*     1 2    to  4 3
*****************************************************************
       subroutine jlp_recent_cmplx(psc, Ns)
       implicit none
       integer Ns
       complex psc(Ns,Ns), tmp
       integer i, j
C Quadrants
C     3 4        2 1
C     1 2    to  4 3
        do i=1,Ns/2
          do j=1,Ns/2
C Flip quadrants 2 and 3:
            tmp = psc(i+Ns/2,j)
            psc(i+Ns/2,j) = psc(i,j+Ns/2)
            psc(i,j+Ns/2) = tmp
C Flip quadrants 1 and 4:
            tmp = psc(i+Ns/2,j+Ns/2)
            psc(i+Ns/2,j+Ns/2) = psc(i,j)
            psc(i,j) = tmp
          end do
        end do

        return
        end
*****************************************************************
* Recenter Fourier transform
* and shift origin from (0,0) to (Ns/2+1, Ns/2+1) or inversely
*
* Old recentering version from original program was not compatible
* with "fourn1" (and relative to an unknown data structure)
*
* Quadrants
*     3 4        2 1
*     1 2    to  4 3
*****************************************************************
       subroutine jlp_recent_real(pwr, Np)
       implicit none
       integer Np
       real pwr(Np,Np), tmp
       integer i, j
C Quadrants
C     3 4        2 1
C     1 2    to  4 3
        do i=1,Np/2
          do j=1,Np/2
C Flip quadrants 2 and 3:
            tmp = pwr(i+Np/2,j)
            pwr(i+Np/2,j) = pwr(i,j+Np/2)
            pwr(i,j+Np/2) = tmp
C Flip quadrants 1 and 4:
            tmp = pwr(i+Np/2,j+Np/2)
            pwr(i+Np/2,j+Np/2) = pwr(i,j)
            pwr(i,j) = tmp
          end do
        end do

        return
        end
***********************************************************************
* To create an image corresponding to the source
*
* INPUT:
* Np: size of object array (=Ns/2)
* Ns: size of phase screen (512)
* ncomp: number of components for the source
* s_int, s_pos: source information (intensity and position in arcsec)
* Ls: size of phase screen (in m)
* lambda: wavelength (in meters)
* Maxcomp: maximum number of components in source
*
* OUTPUT:
* object(Np,Np): array with ones at the location of the components
* FT_object(Np,Np): Fourier Transform of the object
***********************************************************************
        subroutine create_object(object, FT_object, Np, Ns, ncomp,
     1                          s_int, s_pos, Ls, lambda, Maxcomp)
        implicit none
        integer Np, Ns, ncomp, Maxcomp
        real*4 s_int(Maxcomp), s_pos(Maxcomp,2)
        real*4 object(Np,Np), Ls, lambda, Scale, pi, rapsec
        complex FT_object(Np,Np)
        integer i, j, ix, iy, Ncent, N(2)
        character out_file*60, out_comments*80

* Initialization of variables:
        pi = 3.141592653

* rapsec: radians per arcsecond
        rapsec = pi/(180. * 3600.0)

C Initializing the array:
        do i=1,Np
          do j=1,Np
            object(i,j) = 0.
          end do
        end do

* Scale: in pixels/arcsecond
        Scale = (Ls/lambda)*(real(Np)/real(Ns))*rapsec
        Ncent = Np/2 + 1
        write(6,*)' Scale:', Scale,' pixels/arcsec'

C Loop on all components:
        do i=1,ncomp
* ncomp components in source structure
          ix = Ncent + int(Scale * s_pos(i,1))
          iy = Ncent + int(Scale * s_pos(i,2))
          ix = min(Np, max(1, ix))
          iy = min(Np, max(1, iy))
          write(6,*)' Component #',i,' ix=',ix,' iy=',iy
          object(ix,iy) = object(ix,iy) + s_int(i)
        end do

C Transfer object to FT_object for Fourier transform
        do i=1,Np
          do j=1,Np
            FT_object(i,j)  = complex(object(i,j), 0.)
          end do
        end do

        N(1) = Np
        N(2) = Np
        call fourn1(FT_object,N,2,1)

C Output object for a diagnostic:
          out_file='s_object'
          out_comments='Source'
          call jlp_writeimag(object,Np,Np,Np,out_file,out_comments)
        return
        end
**************************************************************************
* Compute two elementary PSFs PSF1 and PSF2
* from a subwindow of the phase screen starting at x,y
* Take into account wavelength smearing due to finite bandpass
*
* INPUT:
* psc: phase screen to be used for computing the elementary PSFs
* lambda: wavelength (in meters)
* fractional_bw: fractional bandwidth
* nsamp: number of sampling points to take the finite bandwidth into account
* x, y : origin of the subwindow used to extract a phase screen from psc
* ncirc: number of circles for the aperture
* c_pos, c_rad, c_typ: aperture information (coordinate, radius, type)
*
* OUTPUT:
* PSF1, PSF2: elementary PSFs corresponding to real and imaginary
*                  parts of the phase screen
**************************************************************************
        subroutine compute_elementary_PSFs(psc, x, y, Ls,
     1                  lambda, fractional_bw, nsamp,
     1                  ncircle, c_pos, c_rad, c_typ,
     1                  PSF1, PSF2, Ns, Np, Maxap, output_screen)
        implicit none
        real*4 x, y, Ls, lambda, fractional_bw
        integer Ns, Np, Maxap
        complex psc(Ns,Ns)
        real*4  PSF1(Np,Np), PSF2(Np,Np)
        integer nsamp, ncircle, output_screen
* Aperture information (coordinate, radius, type)
        real*4 c_pos(Maxap,2), c_rad(Maxap)
        integer*4 c_typ(Maxap)

* Temporary arrays
        complex PupilFunc1(Np,Np), PupilFunc2(Np,Np)

* Miscellaneous:
        real work(Np,Np), ww
        real factor, xa, ya, ox, oy, Lp
        integer loop1, jx, jy, ix, iy, lx, ly, i, Np_cent
        integer iz, jz, N(2)
        real Delta_lambda, lambda_min, l_step
        character out_file*60, out_comments*80
        complex iiu
* iiu = sqrt(-1) or "i"
        iiu = (0.0,1.0)

        Lp = Ls/Ns
        Np_cent = Np/2+1

C Reset image arrays
        do jx=1,Np
          do jy=1,Np
            PSF1(jx,jy) = 0.0
            PSF2(jx,jy) = 0.0
          end do
        end do

* Maximum variation of lambda is Delta_lambda
        Delta_lambda = fractional_bw * lambda
        lambda_min = lambda * ( 1. - fractional_bw / 2.)
        l_step = Delta_lambda / nsamp

******************* BEGIN OF LOOP1 ********************
********* on all the (nsamp) wavelengths belonging to the bandwidth *******
        do 100 loop1=1,nsamp
**************** intermediate loop *****************
* nsamp data points within the bandpass
* Old version: wrong!
*         factor =  1.0 + fractional_bw*(loop1 - INT(nsamp/2))
* JLP's version since psc is proportional to kk = 2 pi / lambda:
         factor =  lambda / (lambda_min + loop1 * l_step)
         write(6,*)'loop1=',loop1,' factor=',factor

C Reset temporary arrays
        do jx=1,Np
          do jy=1,Np
             PupilFunc1(jx,jy) = (0.0,0.0)
             PupilFunc2(jx,jy) = (0.0,0.0)
          end do
        end do

C Loop on all the circular apertures
          do 30 i=1,ncircle
C FOR DEBUG:
C            write(6,*)'Circle #',i,' centered on x+cposx, y+cposy'
C            write(6,*) '  x=',x,' y=',y,' cposx=',c_pos(i,1)
C            write(6,*)' c_posy=',c_pos(i,2),' c_rad(i)=',c_rad(i)
C
*-----------------------------------------
*       filling pdata with aperture phases

           do 40 xa = x+c_pos(i,1)-c_rad(i), x+c_pos(i,1)+c_rad(i), Lp
           do 50 ya = y+c_pos(i,2)-c_rad(i), y+c_pos(i,2)+c_rad(i), Lp
             ox = xa-x-c_pos(i,1)
             oy = ya-y-c_pos(i,2)
             if( ox*ox+oy*oy .lt. c_rad(i)*c_rad(i) ) then
* Np_cent = Np/2+1
               ix = nint( (xa-x)/Lp )+Np_cent
               iy = nint( (ya-y)/Lp )+Np_cent

* Shift origin of the window to (Np_cent,Np_cent)
* Lp: pixel scale of phase screen (Lp = Ls/Ns)
               lx = nint(xa/Lp)
               ly = nint(ya/Lp)
               if(lx.lt.0.or.ly.lt.0) then
                write(6,*)'Fatal error: lx=',lx,' ly=',ly
                write(6,*)'Check if xmin > radius in parameter file...'
                stop
               endif

* iiu = sqrt(-1) or "i"
* NB: psc is proportional to kk = 2 pi / lambda
* correction by factor = lambda / (lambda + dlambda):
                PupilFunc1(ix,iy) = cexp(iiu*factor
     1                                *real(psc(lx,ly)) )*c_typ(i)
                PupilFunc2(ix,iy) = cexp(iiu*factor
     1                                *aimag(psc(lx,ly)) )*c_typ(i)

              end if
   50       continue
   40       continue
*-----------------------------------------
   30     continue

C Output real part of complex pupil function:
        if(output_screen.eq.0)then
          do iz=1, Np
            do jz=1, Np
              work(iz, jz) = real(PupilFunc1(iz,jz))
            end do
          end do
          out_file='s_PupilFunc1'
          out_comments='real part of exp (i phase screen)'
          call jlp_writeimag(work,Np,Np,Np,out_file,out_comments)
          output_screen = 1
        endif

* Simulate propagation from aperture plane to detector plane

C        call fourn1(PupilFunc1,N,2,-1,+1)
C        call fourn1(PupilFunc2,N,2,-1,+1)
C JLP2008 (by comparing with s_psc.for):
C fourn1(data,nn,ndim,isign)
        N(1) = Np
        N(2) = Np
        call fourn1(PupilFunc1,N,2,1)
        call fourn1(PupilFunc2,N,2,1)

* The intensity of the Fourier Transform of the Pupil function
* corresponds to an elementary image
*
* Recenter images (necessary for the subsequent convolution ...)
        call jlp_recent_cmplx(PupilFunc1, Np)
        call jlp_recent_cmplx(PupilFunc2, Np)

* Form speckle/fringe patterns
* i.e., intensity of the complex field (PupilFunc1 or PupilFunc2)
        ww = 1. / real(Np * Np)
        do ix=1, Np
          do iy=1, Np
            PSF1(ix,iy) = PSF1(ix,iy) +
     1         ww*real(PupilFunc1(ix,iy)*conjg(PupilFunc1(ix,iy)))
            PSF2(ix,iy) = PSF2(ix,iy) +
     2         ww*real(PupilFunc2(ix,iy)*conjg(PupilFunc2(ix,iy)))
          end do
        end do

  100   continue
******************* END OF LOOP1 (on nsamp) ********************

C Output PSF1:
        if(output_screen.eq.1)then
          out_file='s_psf'
          out_comments='Intensity of complex field in image plane'
          call jlp_writeimag(PSF1,Np,Np,Np,out_file,out_comments)
          output_screen = 2
        endif

        return
        end
********************************************************************
* Compute elementary images by convolving PSF1 with source
* and add the corresponding power spectrum to pwr
*
* INPUT:
* PSF1: elementary PSF
* FT_object: Fourier Transform of the source
* Np: size of power spectrum (=Ns/2)
*
* INPUT/OUTPUT:
* pwr(Np,Np): power spectrum
********************************************************************
       subroutine process_elementary_image(pwr, PSF1,
     1                      FT_object, Np, output_screen)
       implicit none
       integer Np, output_screen
       real*4  pwr(Np,Np), PSF1(Np,Np)
       complex FT_object(Np,Np)

* Temporary arrays
       real*4 ary1(Np,Np)
       complex cary1(Np,Np), TransferFunc(Np,Np)

* Miscellaneous:
       real*4 work(Np,Np)
       integer N(2), jx, jy, iz, jz
       character out_file*60, out_comments*80

        N(1) = Np
        N(2) = Np

C JLP2008
        do jx=1,Np
          do jy=1,Np
             TransferFunc(jx,jy) = complex(PSF1(jx,jy),0.0)
          end do
        end do
        call fourn1(TransferFunc,N,2,1)

C Convolution is done in Fourier domain:
        do jx=1,Np
          do jy=1,Np
C Product is a complex product here!
             cary1(jx,jy) = TransferFunc(jx,jy) * FT_object(jx,jy)
          end do
        end do

        do jx=1,Np
        do jy=1,Np
          pwr(jx,jy) = pwr(jx,jy)
     1                 + real(cary1(jx,jy)*conjg(cary1(jx,jy)))
        end do
        end do

C Output of an elementary frame:
        if(output_screen.eq.2)then

        call fourn1(cary1,N,2,-1)
        do jx=1,Np
          do jy=1,Np
            ary1(jx,jy) = real(cary1(jx,jy))
          end do
        end do
        call jlp_recent_real(ary1, Np)

          do iz=1, Np
            do jz=1, Np
              work(iz, jz) = ary1(iz,jz)
            end do
          end do
          out_file='s_elem_frame'
          out_comments='PSF1 convolved by source'
          call jlp_writeimag(work,Np,Np,Np,out_file,out_comments)
          output_screen = 3
        endif

        return
        end