SUBROUTINE C3FFT(N1,N2,N3,C,LDC1,LDC2,ISIG,CWORK,csize,DWORK,dsize,IERR)
!
!     ..................................................................
! 1.     PROGRAM UNIT 'C3FFT'
!           3-dimensional Fast Fourier Transform of a COMPLEX*16 array
!           FORTRAN 77 SUBROUTINE
!
! 2.     PURPOSE
!           This routine performs either a forward or a backward FFT of
!           three-dimensional double complex (COMPLEX*16) data.
!           The primefactors of the number of datapoints along each
!           dimension of the data array should be small to yield better
!           performance.
!
! 3.     USAGE
!        PARAMETER-DESCRIPTION
!           C      - COMPLEX*16 array                     (input/output)
!                    Input: The (three-dimensional) array containing the
!                           data to be transformed.
!                    Output: the transformed (three-dimensional) data
!           LDC1   - INTEGER variable                            (input)
!                    The exact dimension of the first index of C as
!                    defined in the calling routine.
!           LDC2   - INTEGER variable                            (input)
!                    The exact dimension of the second index of C as
!                    defined in the calling routine.
!           N1     - INTEGER variable                            (input)
!                    The number of datapoints in the first dimension of
!                    array C.
!                    Constraint: N1 .LE. LDC1 (not checked here)
!           N2     - INTEGER variable                            (input)
!                    The number of datapoints in the second dimension of
!                    array C.
!                    Constraint: N2 .LE. LDC2 (not checked here)
!           N3     - INTEGER variable                            (input)
!                    The number of datapoints in the third dimension of
!                    array C.
!           IERR   - INTEGER variable                           (output)
!                    Error indicator.
!                    IERR .EQ. 0 ... no error
!                    IERR .NE. 0 ... currently not supported
!           ISIG   - INTEGER variable                            (input)
!                    Specifies the direction of the transform:
!                       ISIG .LT. 0 ... forward FFT
!                       ISIG .GT. 0 ... backward FFT
!                       ISIG = 0 ...... nothing will be done
!           CWORK  - COMPLEX*16 array                     (input/output)
!                    A work array which must be dimensioned at least
!                    max(N1,N2,N3) in the calling routine.
!           DWORK  - DOUBLE PRECISION array               (input/output)
!                    A work array which must be dimensioned at least
!                    4*(max(N1,N2,N3))+15 in the calling routine.
!
!        USED SUBROUTINES (DIRECTLY CALLED)
!           CFFTB  - backward Fast Fourier Transform (from FFTPACK)
!           CFFTF  - forward Fast Fourier Transform (from FFTPACK)
!           CFFTI  - initialization for CFFTB and CFFTF (from FFTPACK)
!
!        INDIRECTLY CALLED SUBROUTINES
!           PASSB  - (from FFTPACK)
!           PASSB2 - (from FFTPACK)
!           PASSB3 - (from FFTPACK)
!           PASSB4 - (from FFTPACK)
!           PASSB5 - (from FFTPACK)
!           PASSF  - (from FFTPACK)
!           PASSF2 - (from FFTPACK)
!           PASSF3 - (from FFTPACK)
!           PASSF4 - (from FFTPACK)
!           PASSF5 - (from FFTPACK)
!           PIMACH - (from FFTPACK)
!
!        UTILITY-SUBROUTINES (USE BEFOREHAND OR AFTERWARDS)
!           none
!
!        INPUT/OUTPUT (READ/WRITE)
!           none
!
!        MACHINENDEPENDENT PROGRAMPARTS
!           The array containing the three-dimensional data to be
!           transformed is declared as COMPLEX*16.
!
! 4.     REMARKS
!           For repeated usage of this routine no separate set-up
!           routine is provided, because the time needed for this
!           set-up is neglectable compared to the actual transformation.
!
! 5.     METHOD
!           The three-dimensional FFT is done using one-dimensional
!           complex FFT routines (from FFTPACK). This is done by:
!              1. transforming data values along the 1. dimension of C
!              2. transforming data values along the 2. dimension of C
!              3. transforming data values along the 3. dimension of C
!           Because the data elements along the 2. and 3. dimension of
!           C are not stored in contiguous storage locations and
!           FFTPACK-routines don't provide means for specifying a
!           stride, the involved elements are copied into a temporary
!           one-dimensional field before transformation. Afterwards
!           the data values are stored back to their original
!           location in C.
!
!
  IMPLICIT NONE
  INTEGER, intent(in)  :: LDC1,  LDC2,  N1,  N2,  N3,  ISIG, csize, dsize
  INTEGER, intent(out) :: IERR
  DOUBLE PRECISION, intent(inout) :: DWORK(dsize)
  COMPLEX*16, intent(inout)       :: CWORK(csize)
  COMPLEX*16, intent(inout) :: C(LDC1,LDC2,N3)
  !
  INTEGER            I,  J,  K
  !
  IERR = 0
  IF (ISIG .LT. 0) THEN
     !
     !        forward transform in 1. dimension
     !
     CALL CFFTI(N1,DWORK)
     DO K = 1, N3      ! 20
        DO J = 1, N2   ! 10
           CALL CFFTF(N1,C(1,J,K),DWORK)
        ENDDO  !10         CONTINUE
     ENDDO     !20         CONTINUE
     !
     !        forward transform in 2. dimension
     !
     CALL CFFTI(N2,DWORK)
     DO K = 1, N3         ! 60
        DO I = 1, N1      ! 50
           DO J = 1, N2   ! 30
              CWORK(J) = C(I,J,K)
           ENDDO          ! 30          CONTINUE
           CALL CFFTF(N2,CWORK,DWORK)
           DO J = 1, N2   ! 40
              C(I,J,K) = CWORK(J)
           ENDDO          ! 40          CONTINUE
        ENDDO             ! 50          CONTINUE
     ENDDO                ! 60          CONTINUE
     !
     !        forward transform in 3. dimension
     !
     CALL CFFTI(N3,DWORK)
     DO J = 1, N2          ! 100
        DO I = 1, N1       ! 90
           DO K = 1, N3    ! 70
              CWORK(K) = C(I,J,K)
           ENDDO           ! 70          CONTINUE
           CALL CFFTF(N3,CWORK,DWORK)
           DO K = 1, N3    ! 80
              C(I,J,K) = CWORK(K)
           ENDDO           ! 80          CONTINUE
        ENDDO              ! 90          CONTINUE
     ENDDO                 ! 100         CONTINUE
  ELSEIF (ISIG .GT. 0) THEN
     !
     !        backward transform in 1. dimension
     !
     CALL CFFTI(N1,DWORK)
     DO K = 1, N3      ! 120
        DO J = 1, N2   ! 110
           CALL CFFTB(N1,C(1,J,K),DWORK)
        ENDDO          ! 110       CONTINUE
     ENDDO             ! 120       CONTINUE
     !
     !        backward transform in 2. dimension
     !
     CALL CFFTI(N2,DWORK)
     DO K = 1, N3         ! 160
        DO I = 1, N1      ! 150
           DO J = 1, N2   ! 130
              CWORK(J) = C(I,J,K)
           ENDDO          ! 130          CONTINUE
           CALL CFFTB(N2,CWORK,DWORK)
           DO J = 1, N2   ! 140
              C(I,J,K) = CWORK(J)
           ENDDO          ! 140          CONTINUE
        ENDDO             ! 150          CONTINUE
     ENDDO                ! 160          CONTINUE
     !
     !        backward transform in 3. dimension
     !
     CALL CFFTI(N3,DWORK)
     DO J = 1, N2         ! 200
        DO I = 1, N1      ! 190
           DO K = 1, N3   ! 170
              CWORK(K) = C(I,J,K)
           ENDDO          ! 170          CONTINUE
           CALL CFFTB(N3,CWORK,DWORK)
           DO K = 1, N3   ! 180
              C(I,J,K) = CWORK(K)
           ENDDO          ! 180          CONTINUE
        ENDDO             ! 190          CONTINUE
     ENDDO                ! 200          CONTINUE
  ENDIF
  !
  !        End of 'C3FFT'
  !
END SUBROUTINE C3FFT

!     SUBROUTINE CFFTB(N,C,WSAVE)
!
!     SUBROUTINE CFFTB COMPUTES THE BACKWARD COMPLEX DISCRETE FOURIER
!     TRANSFORM (THE FOURIER SYNTHESIS). EQUIVALENTLY , CFFTB COMPUTES
!     A COMPLEX PERIODIC SEQUENCE FROM ITS FOURIER COEFFICIENTS.
!     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C.
!
!     A CALL OF CFFTF FOLLOWED BY A CALL OF CFFTB WILL MULTIPLY THE
!     SEQUENCE BY N.
!
!     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE CFFTB MUST BE
!     INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE).
!
!     INPUT PARAMETERS
!
!
!     N      THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS
!            MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES.
!
!     C      A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
!
!     WSAVE   A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15
!             IN THE PROGRAM THAT CALLS CFFTB. THE WSAVE ARRAY MUST BE
!             INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE) AND A
!             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
!             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE
!             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT
!             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
!             THE SAME WSAVE ARRAY CAN BE USED BY CFFTF AND CFFTB.
!
!     OUTPUT PARAMETERS
!
!     C      FOR J=1,...,N
!
!                C(J)=THE SUM FROM K=1,...,N OF
!
!                      C(K)*EXP(I*(J-1)*(K-1)*2*PI/N)
!
!                            WHERE I=SQRT(-1)
!
!     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
!             DESTROYED BETWEEN CALLS OF SUBROUTINE CFFTF OR CFFTB
!
SUBROUTINE CFFTB (N,C,WSAVE)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION       C(*)       ,WSAVE(*)
  !
  IF (N .EQ. 1) RETURN
  IW1 = N+N+1
  IW2 = IW1+N+N
  CALL CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
  RETURN
END SUBROUTINE CFFTB

SUBROUTINE CFFTB1 (N,C,CH,WA,IFAC)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION       CH(*)      ,C(*)       ,WA(*)      ,IFAC(*)
  NF = IFAC(2)
  NA = 0
  L1 = 1
  IW = 1
  DO K1=1,NF     ! 116
     IP = IFAC(K1+2)
     L2 = IP*L1
     IDO = N/L2
     IDOT = IDO+IDO
     IDL1 = IDOT*L1
     IF (IP .NE. 4) GO TO 103
     IX2 = IW+IDOT
     IX3 = IX2+IDOT
     IF (NA .NE. 0) GO TO 101
     CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
     GO TO 102
101  CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
102  NA = 1-NA
     GO TO 115
103  IF (IP .NE. 2) GO TO 106
     IF (NA .NE. 0) GO TO 104
     CALL PASSB2 (IDOT,L1,C,CH,WA(IW))
     GO TO 105
104  CALL PASSB2 (IDOT,L1,CH,C,WA(IW))
105  NA = 1-NA
     GO TO 115
106  IF (IP .NE. 3) GO TO 109
     IX2 = IW+IDOT
     IF (NA .NE. 0) GO TO 107
     CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
     GO TO 108
107  CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
108  NA = 1-NA
     GO TO 115
109  IF (IP .NE. 5) GO TO 112
     IX2 = IW+IDOT
     IX3 = IX2+IDOT
     IX4 = IX3+IDOT
     IF (NA .NE. 0) GO TO 110
     CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
     GO TO 111
110  CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
111  NA = 1-NA
     GO TO 115
112  IF (NA .NE. 0) GO TO 113
     CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
     GO TO 114
113  CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
114  IF (NAC .NE. 0) NA = 1-NA
115  L1 = L2
     IW = IW+(IP-1)*IDOT
  ENDDO   ! 116  CONTINUE
  IF (NA .EQ. 0) RETURN
  N2 = N+N
  DO I=1,N2       ! 117
     C(I) = CH(I)
  ENDDO           ! 117     CONTINUE
  RETURN
END SUBROUTINE CFFTB1

!     SUBROUTINE CFFTF(N,C,WSAVE)
!
!     SUBROUTINE CFFTF COMPUTES THE FORWARD COMPLEX DISCRETE FOURIER
!     TRANSFORM (THE FOURIER ANALYSIS). EQUIVALENTLY , CFFTF COMPUTES
!     THE FOURIER COEFFICIENTS OF A COMPLEX PERIODIC SEQUENCE.
!     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C.
!
!     THE TRANSFORM IS NOT NORMALIZED. TO OBTAIN A NORMALIZED TRANSFORM
!     THE OUTPUT MUST BE DIVIDED BY N. OTHERWISE A CALL OF CFFTF
!     FOLLOWED BY A CALL OF CFFTB WILL MULTIPLY THE SEQUENCE BY N.
!
!     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE CFFTF MUST BE
!     INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE).
!
!     INPUT PARAMETERS
!
!
!     N      THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS
!            MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. N
!
!     C      A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
!
!     WSAVE   A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15
!             IN THE PROGRAM THAT CALLS CFFTF. THE WSAVE ARRAY MUST BE
!             INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE) AND A
!             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
!             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE
!             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT
!             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
!             THE SAME WSAVE ARRAY CAN BE USED BY CFFTF AND CFFTB.
!
!     OUTPUT PARAMETERS
!
!     C      FOR J=1,...,N
!
!                C(J)=THE SUM FROM K=1,...,N OF
!
!                      C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N)
!
!                            WHERE I=SQRT(-1)
!
!     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
!             DESTROYED BETWEEN CALLS OF SUBROUTINE CFFTF OR CFFTB
!
SUBROUTINE CFFTF (N,C,WSAVE)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION       C(*)       ,WSAVE(*)
  !
  IF (N .EQ. 1) RETURN
  IW1 = N+N+1
  IW2 = IW1+N+N
  CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
  RETURN
END SUBROUTINE CFFTF

SUBROUTINE CFFTF1 (N,C,CH,WA,IFAC)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION    CH(*),C(*),WA(*),IFAC(*)
  NF = IFAC(2)
  NA = 0
  L1 = 1
  IW = 1
  DO K1=1,NF           ! 116
     IP = IFAC(K1+2)
     L2 = IP*L1
     IDO = N/L2
     IDOT = IDO+IDO
     IDL1 = IDOT*L1
     IF (IP .NE. 4) GO TO 103
     IX2 = IW+IDOT
     IX3 = IX2+IDOT
     IF (NA .NE. 0) GO TO 101
     CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
     GO TO 102
101  CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
102  NA = 1-NA
     GO TO 115
103  IF (IP .NE. 2) GO TO 106
     IF (NA .NE. 0) GO TO 104
     CALL PASSF2 (IDOT,L1,C,CH,WA(IW))
     GO TO 105
104  CALL PASSF2 (IDOT,L1,CH,C,WA(IW))
105  NA = 1-NA
     GO TO 115
106  IF (IP .NE. 3) GO TO 109
     IX2 = IW+IDOT
     IF (NA .NE. 0) GO TO 107
     CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
     GO TO 108
107  CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
108  NA = 1-NA
     GO TO 115
109  IF (IP .NE. 5) GO TO 112
     IX2 = IW+IDOT
     IX3 = IX2+IDOT
     IX4 = IX3+IDOT
     IF (NA .NE. 0) GO TO 110
     CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
     GO TO 111
110  CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
111  NA = 1-NA
     GO TO 115
112  IF (NA .NE. 0) GO TO 113
     CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
     GO TO 114
113  CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
114  IF (NAC .NE. 0) NA = 1-NA
115  L1 = L2
     IW = IW+(IP-1)*IDOT
  ENDDO !116  CONTINUE
  IF (NA .EQ. 0) RETURN
  N2 = N+N
  DO I=1,N2               ! 117
     C(I) = CH(I)
  ENDDO                   ! 117     CONTINUE
  RETURN
END SUBROUTINE CFFTF1

!     SUBROUTINE CFFTI(N,WSAVE)
!
!     SUBROUTINE CFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
!     BOTH CFFTF AND CFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH
!     A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
!     STORED IN WSAVE.
!
!     INPUT PARAMETER
!
!     N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED
!
!     OUTPUT PARAMETER
!
!     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4*N+15
!             THE SAME WORK ARRAY CAN BE USED FOR BOTH CFFTF AND CFFTB
!             AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS
!             ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF
!             WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF CFFTF OR CFFTB.
!
SUBROUTINE CFFTI (N,WSAVE)
  IMPLICIT REAL*8  (A-H,O-Z)
  DIMENSION        WSAVE(*)
  !
  IF (N .EQ. 1) RETURN
  IW1 = N+N+1
  IW2 = IW1+N+N
  CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2))
  RETURN
END SUBROUTINE CFFTI

SUBROUTINE CFFTI1 (N,WA,IFAC)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION       WA(*)      ,IFAC(*)    ,NTRYH(4)
  DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/
  NL = N
  NF = 0
  J = 0
101 J = J+1
  IF (J-4) 102,102,103
102 NTRY = NTRYH(J)
  GO TO 104
103 NTRY = NTRY+2
104 NQ = NL/NTRY
  NR = NL-NTRY*NQ
  IF (NR) 101,105,101
105 NF = NF+1
  IFAC(NF+2) = NTRY
  NL = NQ
  IF (NTRY .NE. 2) GO TO 107
  IF (NF .EQ. 1) GO TO 107
  DO I=2,NF     ! 106
     IB = NF-I+2
     IFAC(IB+2) = IFAC(IB+1)
  ENDDO         ! 106  CONTINUE
  IFAC(3) = 2
107 IF (NL .NE. 1) GO TO 104
  IFAC(1) = N
  IFAC(2) = NF
  TPI = 2.0D+0*PIMACH(DUM)
  ARGH = TPI/DFLOAT(N)
  I = 2
  L1 = 1
  DO K1=1,NF            ! 110
     IP = IFAC(K1+2)
     LD = 0
     L2 = L1*IP
     IDO = N/L2
     IDOT = IDO+IDO+2
     IPM = IP-1
     DO J=1,IPM         ! 109
        I1 = I
        WA(I-1) = 1.0D+0
        WA(I) = 0.0D+0
        LD = LD+L1
        FI = 0.0D+0
        ARGLD = DFLOAT(LD)*ARGH
        DO II=4,IDOT,2  ! 108
           I = I+2
           FI = FI+1.0D+0
           ARG = FI*ARGLD
           WA(I-1) = COS(ARG)
           WA(I) = SIN(ARG)
        ENDDO           ! 108        CONTINUE
        IF (IP .LE. 5) CYCLE !GO TO 109
        WA(I1-1) = WA(I-1)
        WA(I1) = WA(I)
     ENDDO              ! 109        CONTINUE

     L1 = L2
  ENDDO                 ! 110 CONTINUE
  RETURN
END SUBROUTINE CFFTI1

SUBROUTINE PASSB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION       CH(IDO,L1,IP),CC(IDO,IP,L1),C1(IDO,L1,IP),WA(*),C2(IDL1,IP),CH2(IDL1,IP)
  IDOT = IDO/2
  NT = IP*IDL1
  IPP2 = IP+2
  IPPH = (IP+1)/2
  IDP = IP*IDO
  !
  IF (IDO .LT. L1) GO TO 106
  DO J=2,IPPH                  ! 103
     JC = IPP2-J
     DO K=1,L1                 ! 102
        DO I=1,IDO             ! 101
           CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
           CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
        ENDDO                  ! 101 CONTINUE
     ENDDO                     ! 102 CONTINUE
  ENDDO                        ! 103 CONTINUE
  DO K=1,L1                    ! 105
     DO I=1,IDO                ! 104
        CH(I,K,1) = CC(I,1,K)
     ENDDO                     ! 104 CONTINUE
  ENDDO                        ! 105 CONTINUE
  GO TO 112
106 CONTINUE
  DO J=2,IPPH                  ! 109
     JC = IPP2-J
     DO I=1,IDO                ! 108
        DO K=1,L1              ! 107
           CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
           CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
        ENDDO                  ! 107        CONTINUE
     ENDDO                     ! 108        CONTINUE
  ENDDO                        ! 109        CONTINUE

  DO I=1,IDO                  ! 111
     DO K=1,L1                ! 110
        CH(I,K,1) = CC(I,1,K)
     ENDDO                    ! 110 CONTINUE
  ENDDO                       ! 111 CONTINUE
112 IDL = 2-IDO
  INC = 0
  DO L=2,IPPH                 ! 116
     LC = IPP2-L
     IDL = IDL+IDO
     DO IK=1,IDL1             ! 113
        C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
        C2(IK,LC) = WA(IDL)*CH2(IK,IP)
     ENDDO                    ! 113    CONTINUE
     IDLJ = IDL
     INC = INC+IDO
     DO J=3,IPPH              ! 115
        JC = IPP2-J
        IDLJ = IDLJ+INC
        IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
        WAR = WA(IDLJ-1)
        WAI = WA(IDLJ)
        DO IK=1,IDL1          ! 114
           C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
           C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC)
        ENDDO                 ! 114 CONTINUE
     ENDDO                    ! 115 CONTINUE
  ENDDO                       ! 116 CONTINUE
  DO J=2,IPPH                 ! 118
     DO IK=1,IDL1             ! 117
        CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
     ENDDO                    ! 117 CONTINUE
  ENDDO                       ! 118 CONTINUE
  DO J=2,IPPH                 ! 120
     JC = IPP2-J
     DO IK=2,IDL1,2           ! 119
        CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
        CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
        CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
        CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
     ENDDO                    ! 119 CONTINUE
  ENDDO                       ! 120 CONTINUE
  NAC = 1
  IF (IDO .EQ. 2) RETURN
  NAC = 0
  DO IK=1,IDL1                ! 121
     C2(IK,1) = CH2(IK,1)
  ENDDO                       ! 121  CONTINUE
  DO J=2,IP                   ! 123
     DO K=1,L1                ! 122
        C1(1,K,J) = CH(1,K,J)
        C1(2,K,J) = CH(2,K,J)
     ENDDO                    ! 122 CONTINUE
  ENDDO                       ! 123 CONTINUE
  IF (IDOT .GT. L1) GO TO 127
  IDIJ = 0
  DO J=2,IP                 ! 126
     IDIJ = IDIJ+2
     DO I=4,IDO,2           ! 125
        IDIJ = IDIJ+2
        DO K=1,L1           ! 124
           C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
           C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
        ENDDO               ! 124 CONTINUE
     ENDDO                  ! 125 CONTINUE
  ENDDO                     ! 126 CONTINUE
  RETURN
127 IDJ = 2-IDO
  DO J=2,IP                ! 130
     IDJ = IDJ+IDO
     DO K=1,L1             ! 129
        IDIJ = IDJ
        DO I=4,IDO,2       ! 128
           IDIJ = IDIJ+2
           C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
           C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
        ENDDO              ! 128 CONTINUE
     ENDDO                 ! 129 CONTINUE
  ENDDO                    ! 130 CONTINUE
  RETURN
END SUBROUTINE PASSB

SUBROUTINE PASSB2 (IDO,L1,CC,CH,WA1)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION  CC(IDO,2,L1),CH(IDO,L1,2),WA1(*)
  IF (IDO .GT. 2) GO TO 102
  DO K=1,L1         ! 101
     CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
     CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
     CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
     CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  ENDDO             ! 101  CONTINUE
  RETURN
102 CONTINUE
  DO K=1,L1         ! 104
     DO I=2,IDO,2   ! 103
        CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
        TR2 = CC(I-1,1,K)-CC(I-1,2,K)
        CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
        TI2 = CC(I,1,K)-CC(I,2,K)
        CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2
        CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2
     ENDDO          ! 103    CONTINUE
  ENDDO             ! 104 CONTINUE
  RETURN
END SUBROUTINE PASSB2

SUBROUTINE PASSB3 (IDO,L1,CC,CH,WA1,WA2)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION   CC(IDO,3,L1),CH(IDO,L1,3),WA1(*),WA2(*)
  DATA TAUR,TAUI /-0.5D+0,0.866025403784439D+0/
  IF (IDO .NE. 2) GO TO 102
  DO K=1,L1  ! 101
     TR2 = CC(1,2,K)+CC(1,3,K)
     CR2 = CC(1,1,K)+TAUR*TR2
     CH(1,K,1) = CC(1,1,K)+TR2
     TI2 = CC(2,2,K)+CC(2,3,K)
     CI2 = CC(2,1,K)+TAUR*TI2
     CH(2,K,1) = CC(2,1,K)+TI2
     CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
     CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
     CH(1,K,2) = CR2-CI3
     CH(1,K,3) = CR2+CI3
     CH(2,K,2) = CI2+CR3
     CH(2,K,3) = CI2-CR3
  ENDDO ! 101  CONTINUE
  RETURN
102 CONTINUE
  DO K=1,L1                ! 104
     DO I=2,IDO,2          ! 103
        TR2 = CC(I-1,2,K)+CC(I-1,3,K)
        CR2 = CC(I-1,1,K)+TAUR*TR2
        CH(I-1,K,1) = CC(I-1,1,K)+TR2
        TI2 = CC(I,2,K)+CC(I,3,K)
        CI2 = CC(I,1,K)+TAUR*TI2
        CH(I,K,1) = CC(I,1,K)+TI2
        CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
        CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
        DR2 = CR2-CI3
        DR3 = CR2+CI3
        DI2 = CI2+CR3
        DI3 = CI2-CR3
        CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
        CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
        CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
        CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
     ENDDO                ! 103    CONTINUE
  ENDDO ! 104     CONTINUE
  RETURN
END SUBROUTINE PASSB3

SUBROUTINE PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION CC(IDO,4,L1),CH(IDO,L1,4),WA1(*),WA2(*),WA3(*)
  IF (IDO .NE. 2) GO TO 102
  DO K=1,L1     ! 101
     TI1 = CC(2,1,K)-CC(2,3,K)
     TI2 = CC(2,1,K)+CC(2,3,K)
     TR4 = CC(2,4,K)-CC(2,2,K)
     TI3 = CC(2,2,K)+CC(2,4,K)
     TR1 = CC(1,1,K)-CC(1,3,K)
     TR2 = CC(1,1,K)+CC(1,3,K)
     TI4 = CC(1,2,K)-CC(1,4,K)
     TR3 = CC(1,2,K)+CC(1,4,K)
     CH(1,K,1) = TR2+TR3
     CH(1,K,3) = TR2-TR3
     CH(2,K,1) = TI2+TI3
     CH(2,K,3) = TI2-TI3
     CH(1,K,2) = TR1+TR4
     CH(1,K,4) = TR1-TR4
     CH(2,K,2) = TI1+TI4
     CH(2,K,4) = TI1-TI4
  ENDDO ! 101 CONTINUE
  RETURN
102 CONTINUE
  DO K=1,L1            ! 104
     DO I=2,IDO,2      ! 103
        TI1 = CC(I,1,K)-CC(I,3,K)
        TI2 = CC(I,1,K)+CC(I,3,K)
        TI3 = CC(I,2,K)+CC(I,4,K)
        TR4 = CC(I,4,K)-CC(I,2,K)
        TR1 = CC(I-1,1,K)-CC(I-1,3,K)
        TR2 = CC(I-1,1,K)+CC(I-1,3,K)
        TI4 = CC(I-1,2,K)-CC(I-1,4,K)
        TR3 = CC(I-1,2,K)+CC(I-1,4,K)
        CH(I-1,K,1) = TR2+TR3
        CR3 = TR2-TR3
        CH(I,K,1) = TI2+TI3
        CI3 = TI2-TI3
        CR2 = TR1+TR4
        CR4 = TR1-TR4
        CI2 = TI1+TI4
        CI4 = TI1-TI4
        CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2
        CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2
        CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3
        CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3
        CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4
        CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4
     ENDDO          ! 103 CONTINUE
  ENDDO             ! 104 CONTINUE
  RETURN
END SUBROUTINE PASSB4

SUBROUTINE PASSB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION  CC(IDO,5,L1),CH(IDO,L1,5),WA1(*),WA2(*),WA3(*),WA4(*)
  DATA TR11,TI11,TR12,TI12 /0.309016994374947D+0,0.951056516295154D+0,-0.809016994374947D+0,0.587785252292473D+0/
  IF (IDO .NE. 2) GO TO 102
  DO K=1,L1       ! 101
     TI5 = CC(2,2,K)-CC(2,5,K)
     TI2 = CC(2,2,K)+CC(2,5,K)
     TI4 = CC(2,3,K)-CC(2,4,K)
     TI3 = CC(2,3,K)+CC(2,4,K)
     TR5 = CC(1,2,K)-CC(1,5,K)
     TR2 = CC(1,2,K)+CC(1,5,K)
     TR4 = CC(1,3,K)-CC(1,4,K)
     TR3 = CC(1,3,K)+CC(1,4,K)
     CH(1,K,1) = CC(1,1,K)+TR2+TR3
     CH(2,K,1) = CC(2,1,K)+TI2+TI3
     CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
     CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
     CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
     CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
     CR5 = TI11*TR5+TI12*TR4
     CI5 = TI11*TI5+TI12*TI4
     CR4 = TI12*TR5-TI11*TR4
     CI4 = TI12*TI5-TI11*TI4
     CH(1,K,2) = CR2-CI5
     CH(1,K,5) = CR2+CI5
     CH(2,K,2) = CI2+CR5
     CH(2,K,3) = CI3+CR4
     CH(1,K,3) = CR3-CI4
     CH(1,K,4) = CR3+CI4
     CH(2,K,4) = CI3-CR4
     CH(2,K,5) = CI2-CR5
  ENDDO ! 101 CONTINUE
  RETURN
102 CONTINUE
  DO K=1,L1               ! 104
     DO I=2,IDO,2         ! 103
        TI5 = CC(I,2,K)-CC(I,5,K)
        TI2 = CC(I,2,K)+CC(I,5,K)
        TI4 = CC(I,3,K)-CC(I,4,K)
        TI3 = CC(I,3,K)+CC(I,4,K)
        TR5 = CC(I-1,2,K)-CC(I-1,5,K)
        TR2 = CC(I-1,2,K)+CC(I-1,5,K)
        TR4 = CC(I-1,3,K)-CC(I-1,4,K)
        TR3 = CC(I-1,3,K)+CC(I-1,4,K)
        CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
        CH(I,K,1) = CC(I,1,K)+TI2+TI3
        CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
        CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
        CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
        CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
        CR5 = TI11*TR5+TI12*TR4
        CI5 = TI11*TI5+TI12*TI4
        CR4 = TI12*TR5-TI11*TR4
        CI4 = TI12*TI5-TI11*TI4
        DR3 = CR3-CI4
        DR4 = CR3+CI4
        DI3 = CI3+CR4
        DI4 = CI3-CR4
        DR5 = CR2+CI5
        DR2 = CR2-CI5
        DI5 = CI2-CR5
        DI2 = CI2+CR5
        CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
        CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
        CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
        CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
        CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4
        CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4
        CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5
        CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5
     ENDDO               ! 103 CONTINUE
  ENDDO                  ! 104 CONTINUE
  RETURN
END SUBROUTINE PASSB5

SUBROUTINE PASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION   CH(IDO,L1,IP),CC(IDO,IP,L1),C1(IDO,L1,IP),WA(*),C2(IDL1,IP),CH2(IDL1,IP)
  IDOT = IDO/2
  NT = IP*IDL1
  IPP2 = IP+2
  IPPH = (IP+1)/2
  IDP = IP*IDO
  !
  IF (IDO .LT. L1) GO TO 106
  DO J=2,IPPH       ! 103
     JC = IPP2-J
     DO K=1,L1      ! 102
        DO I=1,IDO  ! 101
           CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
           CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
        ENDDO       ! 101    CONTINUE
     ENDDO          ! 102    CONTINUE
  ENDDO             ! 103    CONTINUE

  DO K=1,L1         ! 105
     DO I=1,IDO     ! 104
        CH(I,K,1) = CC(I,1,K)
     ENDDO          ! 104    CONTINUE
  ENDDO             ! 105    CONTINUE

  GO TO 112
106 CONTINUE
  DO J=2,IPPH        ! 109
     JC = IPP2-J
     DO I=1,IDO      ! 108
        DO K=1,L1    ! 107
           CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
           CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
        ENDDO       ! 107        CONTINUE
     ENDDO          ! 108        CONTINUE
  ENDDO             ! 109        CONTINUE

  DO I=1,IDO        ! 111
     DO K=1,L1      ! 110
        CH(I,K,1) = CC(I,1,K)
     ENDDO          ! 110     CONTINUE
  ENDDO             ! 111     CONTINUE
112 CONTINUE
  IDL = 2-IDO
  INC = 0
  DO L=2,IPPH       ! 116
     LC = IPP2-L
     IDL = IDL+IDO
     DO IK=1,IDL1   ! 113
        C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
        C2(IK,LC) = -WA(IDL)*CH2(IK,IP)
     ENDDO          ! 113    CONTINUE
     IDLJ = IDL
     INC = INC+IDO
     DO J=3,IPPH   ! 115
        JC = IPP2-J
        IDLJ = IDLJ+INC
        IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
        WAR = WA(IDLJ-1)
        WAI = WA(IDLJ)
        DO IK=1,IDL1   ! 114
           C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
           C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)
        ENDDO          ! 114  CONTINUE
     ENDDO             ! 115    CONTINUE
  ENDDO                ! 116 CONTINUE
  DO J=2,IPPH          ! 118
     DO IK=1,IDL1      ! 117
        CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
     ENDDO             ! 117    CONTINUE
  ENDDO                ! 118 CONTINUE
  DO J=2,IPPH          ! 120
     JC = IPP2-J
     DO IK=2,IDL1,2    ! 119
        CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
        CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
        CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
        CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
     ENDDO             ! 119     CONTINUE
  ENDDO                ! 120 CONTINUE
  NAC = 1
  IF (IDO .EQ. 2) RETURN
  NAC = 0
  DO IK=1,IDL1         ! 121
     C2(IK,1) = CH2(IK,1)
  ENDDO                ! 121 CONTINUE
  DO J=2,IP            ! 123
     DO K=1,L1         ! 122
        C1(1,K,J) = CH(1,K,J)
        C1(2,K,J) = CH(2,K,J)
     ENDDO             ! 122 CONTINUE
  ENDDO                ! 123 CONTINUE
  IF (IDOT .GT. L1) GO TO 127
  IDIJ = 0
  DO J=2,IP           ! 126
     IDIJ = IDIJ+2
     DO I=4,IDO,2     ! 125
        IDIJ = IDIJ+2
        DO K=1,L1     ! 124
           C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
           C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
        ENDDO         ! 124 CONTINUE
     ENDDO            ! 125 CONTINUE
  ENDDO               ! 126 CONTINUE
  RETURN
127 IDJ = 2-IDO
  DO J=2,IP           ! 130
     IDJ = IDJ+IDO
     DO K=1,L1        ! 129
        IDIJ = IDJ
        DO I=4,IDO,2  ! 128
           IDIJ = IDIJ+2
           C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
           C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
        ENDDO         ! 128 CONTINUE
     ENDDO            ! 129 CONTINUE
  ENDDO               ! 130 CONTINUE
  RETURN
END SUBROUTINE PASSF

SUBROUTINE PASSF2 (IDO,L1,CC,CH,WA1)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION CC(IDO,2,L1),CH(IDO,L1,2),WA1(*)
  IF (IDO .GT. 2) GO TO 102
  DO K=1,L1 ! 101
     CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
     CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
     CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
     CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  ENDDO     ! 101 CONTINUE
  RETURN
102 CONTINUE
  DO K=1,L1        ! 104
     DO I=2,IDO,2  ! 103
        CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
        TR2 = CC(I-1,1,K)-CC(I-1,2,K)
        CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
        TI2 = CC(I,1,K)-CC(I,2,K)
        CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2
        CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2
     ENDDO         !  103    CONTINUE
  ENDDO            ! 104 CONTINUE
  RETURN
END SUBROUTINE PASSF2

SUBROUTINE PASSF3 (IDO,L1,CC,CH,WA1,WA2)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION  CC(IDO,3,L1),CH(IDO,L1,3),WA1(*),WA2(*)
  DATA TAUR,TAUI /-0.5D+0,-0.866025403784439D+0/
  IF (IDO .NE. 2) GO TO 102

  ! !$OMP PARALLEL DO SHARED(CC,CH,TAUR,TAUI) PRIVATE(TR2,TI2,CR2,CI2,CR3,CI3) SCHEDULE(STATIC)
  DO K=1,L1
     TR2 = CC(1,2,K)+CC(1,3,K)
     CR2 = CC(1,1,K)+TAUR*TR2
     CH(1,K,1) = CC(1,1,K)+TR2
     TI2 = CC(2,2,K)+CC(2,3,K)
     CI2 = CC(2,1,K)+TAUR*TI2
     CH(2,K,1) = CC(2,1,K)+TI2
     CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
     CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
     CH(1,K,2) = CR2-CI3
     CH(1,K,3) = CR2+CI3
     CH(2,K,2) = CI2+CR3
     CH(2,K,3) = CI2-CR3
  ENDDO
  ! !$OMP END PARALLEL DO

  RETURN
102 CONTINUE
  ! !$OMP PARALLEL DO SHARED(CC,CH,TAUR,TAUI,WA1,WA2) PRIVATE(I,TR2,TI2,CR2,CI2,CR3,CI3,DR2,DI2,DR3,DI3) SCHEDULE(STATIC)
  DO K=1,L1
     DO I=2,IDO,2
        TR2 = CC(I-1,2,K)+CC(I-1,3,K)
        CR2 = CC(I-1,1,K)+TAUR*TR2
        CH(I-1,K,1) = CC(I-1,1,K)+TR2
        TI2 = CC(I,2,K)+CC(I,3,K)
        CI2 = CC(I,1,K)+TAUR*TI2
        CH(I,K,1) = CC(I,1,K)+TI2
        CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
        CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
        DR2 = CR2-CI3
        DR3 = CR2+CI3
        DI2 = CI2+CR3
        DI3 = CI2-CR3
        CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
        CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
        CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
        CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
     ENDDO
  ENDDO
  ! !$OMP END PARALLEL DO
  RETURN
END SUBROUTINE PASSF3

SUBROUTINE PASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION  CC(IDO,4,L1),CH(IDO,L1,4),WA1(*),WA2(*),WA3(*)
  IF (IDO .NE. 2) GO TO 102
  DO K=1,L1   ! 101
     TI1 = CC(2,1,K)-CC(2,3,K)
     TI2 = CC(2,1,K)+CC(2,3,K)
     TR4 = CC(2,2,K)-CC(2,4,K)
     TI3 = CC(2,2,K)+CC(2,4,K)
     TR1 = CC(1,1,K)-CC(1,3,K)
     TR2 = CC(1,1,K)+CC(1,3,K)
     TI4 = CC(1,4,K)-CC(1,2,K)
     TR3 = CC(1,2,K)+CC(1,4,K)
     CH(1,K,1) = TR2+TR3
     CH(1,K,3) = TR2-TR3
     CH(2,K,1) = TI2+TI3
     CH(2,K,3) = TI2-TI3
     CH(1,K,2) = TR1+TR4
     CH(1,K,4) = TR1-TR4
     CH(2,K,2) = TI1+TI4
     CH(2,K,4) = TI1-TI4
  ENDDO       ! 101 CONTINUE
  RETURN
102 CONTINUE
  DO K=1,L1           ! 104
     DO I=2,IDO,2     ! 103
        TI1 = CC(I,1,K)-CC(I,3,K)
        TI2 = CC(I,1,K)+CC(I,3,K)
        TI3 = CC(I,2,K)+CC(I,4,K)
        TR4 = CC(I,2,K)-CC(I,4,K)
        TR1 = CC(I-1,1,K)-CC(I-1,3,K)
        TR2 = CC(I-1,1,K)+CC(I-1,3,K)
        TI4 = CC(I-1,4,K)-CC(I-1,2,K)
        TR3 = CC(I-1,2,K)+CC(I-1,4,K)
        CH(I-1,K,1) = TR2+TR3
        CR3 = TR2-TR3
        CH(I,K,1) = TI2+TI3
        CI3 = TI2-TI3
        CR2 = TR1+TR4
        CR4 = TR1-TR4
        CI2 = TI1+TI4
        CI4 = TI1-TI4
        CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2
        CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2
        CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3
        CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3
        CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4
        CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4
     ENDDO          ! 103     CONTINUE
  ENDDO             ! 104     CONTINUE
  RETURN
END SUBROUTINE PASSF4

SUBROUTINE PASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
  IMPLICIT REAL*8     (A-H,O-Z)
  DIMENSION       CC(IDO,5,L1), CH(IDO,L1,5), WA1(*), WA2(*), WA3(*), WA4(*)
  DATA TR11,TI11,TR12,TI12 /0.309016994374947D+0,-0.951056516295154D+0,-0.809016994374947D+0,-0.587785252292473D+0/
  IF (IDO .NE. 2) GO TO 102
  DO K=1,L1   ! 101
     TI5 = CC(2,2,K)-CC(2,5,K)
     TI2 = CC(2,2,K)+CC(2,5,K)
     TI4 = CC(2,3,K)-CC(2,4,K)
     TI3 = CC(2,3,K)+CC(2,4,K)
     TR5 = CC(1,2,K)-CC(1,5,K)
     TR2 = CC(1,2,K)+CC(1,5,K)
     TR4 = CC(1,3,K)-CC(1,4,K)
     TR3 = CC(1,3,K)+CC(1,4,K)
     CH(1,K,1) = CC(1,1,K)+TR2+TR3
     CH(2,K,1) = CC(2,1,K)+TI2+TI3
     CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
     CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
     CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
     CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
     CR5 = TI11*TR5+TI12*TR4
     CI5 = TI11*TI5+TI12*TI4
     CR4 = TI12*TR5-TI11*TR4
     CI4 = TI12*TI5-TI11*TI4
     CH(1,K,2) = CR2-CI5
     CH(1,K,5) = CR2+CI5
     CH(2,K,2) = CI2+CR5
     CH(2,K,3) = CI3+CR4
     CH(1,K,3) = CR3-CI4
     CH(1,K,4) = CR3+CI4
     CH(2,K,4) = CI3-CR4
     CH(2,K,5) = CI2-CR5
  ENDDO ! 101  CONTINUE
  RETURN
102 CONTINUE
  DO K=1,L1        ! 104
     DO I=2,IDO,2  ! 103
        TI5 = CC(I,2,K)-CC(I,5,K)
        TI2 = CC(I,2,K)+CC(I,5,K)
        TI4 = CC(I,3,K)-CC(I,4,K)
        TI3 = CC(I,3,K)+CC(I,4,K)
        TR5 = CC(I-1,2,K)-CC(I-1,5,K)
        TR2 = CC(I-1,2,K)+CC(I-1,5,K)
        TR4 = CC(I-1,3,K)-CC(I-1,4,K)
        TR3 = CC(I-1,3,K)+CC(I-1,4,K)
        CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
        CH(I,K,1) = CC(I,1,K)+TI2+TI3
        CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
        CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
        CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
        CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
        CR5 = TI11*TR5+TI12*TR4
        CI5 = TI11*TI5+TI12*TI4
        CR4 = TI12*TR5-TI11*TR4
        CI4 = TI12*TI5-TI11*TI4
        DR3 = CR3-CI4
        DR4 = CR3+CI4
        DI3 = CI3+CR4
        DI4 = CI3-CR4
        DR5 = CR2+CI5
        DR2 = CR2-CI5
        DI5 = CI2-CR5
        DI2 = CI2+CR5
        CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
        CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
        CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
        CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
        CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4
        CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4
        CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5
        CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5
     ENDDO         ! 103     CONTINUE
  ENDDO            ! 104     CONTINUE
  RETURN
END SUBROUTINE PASSF5

FUNCTION PIMACH (DUM)
  IMPLICIT REAL*8 (A-H,O-Z)
  PIMACH = 4.0D+0*ATAN(1.0D+0)
  RETURN
END FUNCTION PIMACH


program random_normal ! GitHub FortranTip xnormal.f90
use iso_c_binding, only: c_int, c_double
implicit none
!
interface
subroutine normal_vec(seed, n, x) bind(c)
import c_int, c_double
integer(kind=c_int), intent(in), value :: seed, n
real(kind=c_double)                    :: x(n)
end subroutine normal_vec
end interface
!
integer :: seed
integer, parameter :: n = 5
real(kind=c_double) :: x(n)
!
do seed=1,3
   call normal_vec(seed,n,x)
   print "(*(1x,f7.4))",x
end do
end program random_normal
! Compile on WSL2 with
! g++ -c -std=c++17 normal_array.cpp
! gfortran -c xnormal.f90
! gfortran normal_array.o xnormal.o
! output:
!  -0.1220 -1.0868  0.6843 -1.0752  0.0333
!   0.3526 -0.2002 -1.9825 -0.8651  0.9774
!  -1.6147 -1.3718 -0.2794  0.0946  0.2605


CONCOCTED BY R.N.MCLEAN, APPLIED MATHS COURSE, AUCKLAND UNIVERSITY, MCMLXXI.
      INTEGER ENUFF,PRIME(44)
CALCULATION SHOWS PRIME(43) = 181, AND PRIME(44) = 191.
      INTEGER N,F,Q,XP2
      INTEGER INC,IP,LP,PP
      INTEGER ALINE(20),LL,I
      DATA ENUFF/44/
      DATA PP/4/
      DATA PRIME(1),PRIME(2),PRIME(3),PRIME(4)/1,2,3,5/
COPY THE KNOWN PRIMES TO THE OUTPUT LINE.
      DO 1 I = 1,PP
    1   ALINE(I) = PRIME(I)
      LL = PP
      LP = 3
      XP2 = PRIME(LP + 1)**2
      N = 5
      INC = 4
CONSIDER ANOTHER CANDIDATE. VIA INC, DODGE MULTIPLES OF 2 AND 3.
   10 INC = 6 - INC
      N = N + INC
      IF (N - XP2) 20,11,20
   11 LP = LP + 1
      XP2 = PRIME(LP + 1)**2
      GO TO 40
CHECK SUCCESSIVE PRIMES AS FACTORS, STARTING WITH PRIME(4) = 5.
   20 IP = 4
   21 F = PRIME(IP)
      Q = N/F
      IF (Q*F - N) 22,40,22
   22 IP = IP + 1
      IF (IP - LP) 21,21,30
CAUGHT ANOTHER PRIME.
   30 IF (PP - ENUFF) 31,32,32
   31 PP = PP + 1
      PRIME(PP) = N
   32 IF (LL - 20) 35,33,33
   33 WRITE (6,34) (ALINE(I), I = 1,LL)
   34 FORMAT (20I6)
      LL = 0
   35 LL = LL + 1
      ALINE(LL) = N
COMPLETED?
   40 IF (N - 32767) 10,41,41
   41 WRITE (6,34) (ALINE(I), I = 1,LL)
      END


      double precision function psi(xp,yp,zp,t)
      implicit none

      double precision xp,yp,zp,t
      double precision revs_per_second

      double precision pi, pi2
      common /compi/ pi, pi2

      common /spherecomm/ revs_per_second

c     # Solid body rotation
      psi = pi2*revs_per_second*zp

      psi = -psi

      end

      subroutine get_psi_vel(xd1,xd2,ds,vn,t)
      implicit none

      double precision xd1(3),xd2(3), ds, vn, psi,t

      vn = (psi(xd1(1),xd1(2),xd1(3),t) -
     &      psi(xd2(1),xd2(2),xd2(3),t))/ds

      end


C The contents of this file are copyright protected:
C --------------------------------------------------
C NCAR Graphics - UNIX Version 3.1.2
C Copyright (C) 1987, 1988, 1989, 1991
C University Corporation for Atmospheric Research
C All Rights Reserved
C
C Modified for high non-equidistant grids as part
C of the shallow water model STSWM by R. Jakob
C
C#################################################################
C#
C#    SUBROUTINE CPMPXY(IMAP,XINP,YINP,XOTP,YOTP)
C#
C#    THIS ROUTINE PROVIDES A MAPPING FOR NON-EQUALLY SPACED
C#    DATA IN THE CONPACK PACKAGE OF NCAR GRAPHICS. THE
C#    ROUTINE IS DESCRIBED IN VERSION 3.00, PAGES 3-55, 3-56.
C#    SEE ALSO MANUAL PAGES 3-15, 3-16 FOR CORRECT USE
C#
C#    DUMMY ARGUMENTS
C#
C#    INTEGER   IMAP = 0 NO MAPPING, CPMPXY NOT CALLED
C#              IMAP = 1 STANDARD SCALED MAPPING
C#              IMAP = 2 POLAR COORDINATE SYSTEM
C#              IMAP = 3 USER-DEFINED GRID MAPPING (GAUSSIAN)
C#              IMAP IS DEFINED BY THE VALUE OF 'MAP'
C#    REAL XINP,YINP: INPUT DATA
C#    REAL XOTP,YOTP: OUTPUT DATA
C#
C#    CALLED BY: CPCNRC, PLOTS, VELVCT
C#    CALLS: MAPTRN
C#
      SUBROUTINE CPMPXY(IMAP,XINP,YINP,XOTP,YOTP)
C
C*****************************************************************
C
C     DEFINE PARAMETERS
      INCLUDE 'params.i'
C     MAPPING DATA
      INCLUDE 'complt.i'
C
C     PARAMETER TYPES
C
      REAL XINP,YINP,XOTP,YOTP,XLON,YLAT
      INTEGER IMAP
C
C------ Local Parameters -----------------------------------------------
C
      REAL PI
      PARAMETER (PI=3.141592653589793)
C
C     HANDLE INTERMAEDIATE POINTS
C
      INTEGER M,N
      REAL XFRACT, YFRACT, TEST, PLAT, PLON
C
C*********************************************************************
C
      IF (IMAP .EQ. 1) THEN
         CALL MAPTRN(YINP,XINP,XOTP,YOTP)
      ELSE IF (IMAP .EQ. 2) THEN
         XOTP = XINP * COS(PI/180.0 * YINP)
         YOTP = XINP * SIN(PI/180.0 * YINP)
      ELSE IF (IMAP .EQ. 3) THEN
         M = INT(XINP)
         N = INT(YINP)
C
C        COMPUTE LONGITUDE
C
         XFRACT = XINP-REAL(M)
         IF (XFRACT .GT. 0.0) THEN
            XLON = RLOND(M) + (RLOND(M+1)-RLOND(M))*XFRACT
         ELSE
            XLON = RLOND(M)
         ENDIF
C
C        COMPUTE LATITUDE
C
         YFRACT = YINP-REAL(N)
         IF (YFRACT .GT. 0.0) THEN
            YLAT = RLATD(N) + (RLATD(N+1)-RLATD(N))*YFRACT
         ELSE
            YLAT = RLATD(N)
         ENDIF
         CALL MAPTRN(YLAT,XLON,XOTP,YOTP)
C
C        OUT-OF-RANGE VALUES FOR POLAR STEREOGRAPHIC PROJECTION
C
         IF (LPSP) THEN
            IF (LNORTH) THEN
C
C              NORTHERN HEMISPHERE
C
               IF (POROT .EQ. 0.0) THEN
                  TEST = YLAT
               ELSE
                  PLAT = YLAT/180.0*PI
                  PLON = XLON/180.0*PI
                  TEST = SIN(PI/2.0-POROT)*SIN(PLAT) +
     &               COS(PI/2.0-POROT)*COS(PLAT)*COS(-PI-PLON)
               ENDIF
               IF (TEST .LT. 0.0) THEN
                  XOTP = 1.0E12
               ENDIF
            ELSE
C
C              SOUTHERN HEMISPHERE
C
               IF (POROT .EQ. 0.0) THEN
                  TEST = -YLAT
               ELSE
                  PLAT = YLAT/180.0*PI
                  PLON = XLON/180.0*PI
                  TEST = SIN(-PI/2.0+POROT)*SIN(PLAT) +
     &               COS(-PI/2.0+POROT)*COS(PLAT)*COS(-PLON)
               ENDIF
               IF (TEST .LT. 0.0) THEN
                  XOTP = 1.0E12
               ENDIF
            ENDIF
         ENDIF
      ELSE
         XOTP = XINP
         YOTP = YINP
      END IF
      RETURN
      END


        program 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.)
*
*       ! seed for random number generator (large odd integer)
*       Random
*       7597551
*       ! outer scale and inner scale of the turbulence(m) - recommended values
*       Turbulence
*       10.0  0.01
*       ! 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.0  0.0
*       0.5   0.02 0.02
*       ! # 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)
*       Phase_screen
*       1.25 8.75  0.14
*       1.25 8.75  2.5
*       ! total number of frames to be processed
*       Frame
*       100
*       ------ as an option `no atmosphere' can be specified by ------
*       ! obtaining beam pattern
*       No_disturbance
*       --------------------------------------------------------------
*
*       Written in standard FORTRAN and expected to run both on VMS and UNIX
*       simply by replacing FFT routines and random number generator.
*       On UNIX all tempory arrays are to be dynamically allocated by 'calloc()'
*       Source code should be called pscreen.for on VMS, pscreen.f on UNIX.
*       On a vector machine, effeciency of loops should be reconsidered.
*
*       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 l_o = 0.1,
*       while the diffractive effect can be investigated by setting l_0 = 0.4.
*******************************************************************************
*------ declarations ---------*
*       constants
        real*4    pi, twopi

*       integrated structure constant of the phase fluctuation
        real*4 lcn2

*       size of phase screen and resolution (m/pix)
        real*4 l_s, l_p
        parameter( l_s = 10.24 )
        parameter( l_p = 0.02  )

*  size of phase screen
        integer*4 nsise
        parameter( nsize = 256  )

*       wave number, spatial frequencies and scale length of tubulence
        real kk, kapmax, kapmin, l_0, dkap, lambda, l_o

*       complex phase screen, real and imag are independent.
        real*4 pha_re(nsize,nsize),pha_im(nsize,nsize)

*       input control parameter file and output file(s)
        character*30 ifile, ofile

*       I/O units
        integer*4 f_in
        parameter( f_in = 11)

*       variables local to main program
        character*80 comment,ocomments
        integer*4 seed

*       common variables are not compatible with parameter statement.
        pi = 3.141592653
        twopi = 2.*pi
        lcn2 = 5.0e-13

* JLP
        call jlp_begin
        call jlp_inquifmt

*       input file names
        write(*,10)
   10   format(1x,' input ascii file name : ',$)
        read(*,'(a)') ifile

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

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

          read(f_in,30,end=100) comment
          write(*,35) comment

          if( comment(1:1) .eq. '!') goto 40
C Keyword "Random", parameter: seed (random generator):
          if( comment(1:1) .eq. 'R' .or. comment(1:1) .eq. 'r') then
            read(f_in,*) seed
          end if
C Keyword "Turbulence", parameters: outer and inner  scales
          if( comment(1:1) .eq. 'T' .or. comment(1:1) .eq. 't') then
            read(f_in,*) l_0, l_o
          end if
C Keyword "Wavelength", parameters: central wavel., fractional bandwidth,
C sampling points
          if( comment(1:1) .eq. 'W' .or. comment(1:1) .eq. 'w') then
            read(f_in,*) lambda
          end if

   40   continue
  100   continue

            write(6,36) seed,l_0,l_o,lambda
            write(ocomments,36) seed,l_0,l_o,lambda
36	  format(' seed=',I6,' L0 = ',G10.4,' lo = ',G10.4,
     &    ' Lambda = ',G10.4)
* kk: wave number, kap: spatial frequency in aperture plane

        kk = twopi / lambda

        work=min(l_s,l_0)
        kapmin = twopi / work

        work=max(l_o,l_p)
        kapmax = twopi / work

* dkap: one pixel in spatial frequency in aperture plane
        dkap = twopi / l_s
*
* create a complex phase screen
        call jlp_random_init(seed)
        call screen(pha_re,pha_im,nsize,kk,kapmax,kapmin,lcn2,dkap)

        ofile=' '
        print *,' output of phase screen (real part)'
        call jlp_writeimag(pha_re,nsize,nsize,nsize,ofile,ocomments)
        ofile=' '
        print *,' output of phase screen (imaginary part)'
        call jlp_writeimag(pha_im,nsize,nsize,nsize,ofile,ocomments)
*
        call jlp_end
        stop
        end

***************************************************************************
* screen
* creates complex phase screen
***************************************************************************
        subroutine screen(pha_re,pha_im,nsize,kk,kapmax,kapmin,lcn2,dkap)
        real*4 pha_re(nsize,nsize),pha_im(nsize,nsize)
        real*4 fs, fso, pi, twopi
        real*4 kk, kapmax, kapmin, lcn2, dkap, u, wrand, work

*       radial spatial frequency in aperture plane
        real*4 kap

*       dimension array for fft
*       origin of the phase screen
        integer*4 Nc

        pi = 3.141592653
        twopi = 2.*pi

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

        Nc = nsize/2+1
        fs0 = 0.033*pi*lcn2*kk*kk*2.0*dkap*dkap

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

            kap = dkap*sqrt( float((jx-Nc)*(jx-Nc)+(jy-Nc)*(jy-Nc)) )
* kap**(-11/3) is undefined at kap=0.
            kap = max(kap,dkap)

* introducing smooth cut-offs below kapmin and beyond kapmax.
            atten = 1.0
            if(kap .gt. kapmax) then
                atten = exp(-(kap-kapmax)/(5.0*dkap))
            elseif(kap .lt. kapmin) then
                atten = exp(-(kapmin-kap)/(5.0*dkap))
            endif

C Generation of random phase screen:
10          call jlp_random(u)
            if ( u.le.0.0 )goto 10

            radi = sqrt(-2.0*log(u))
            fs = fs0*kap**(-11.0/3.0)
            work = atten*sqrt(fs)*radi

            call jlp_random(wrand)
C psc(jx,jy) = atten*sqrt(fs)*radi*exp(i*2.*pi*wrand)

            wrand = wrand * twopi
            pha_re(jx,jy) = work*cos(wrand)
            pha_im(jx,jy) = work*sin(wrand)

110         continue
100       continue

*---------- Fourier transform ------------------------------
        write(*,555) nsize,nsize
555     format('+', 'start ',i3,'x',i3,' sized fft              ')
        kod = 1
        call fft_2d(pha_re,pha_im,nsize,nsize,nsize,kod)
        write(*,666)
666     format('+', 'end fft for screen                         ')

C We are only interested in the phase term ,
C so we take arbitrary exp(i * phi) with phi = pha_re
C (We could have taken also pha_im)
        do jy=1,nsize
          do jx=1,nsize
            work = pha_re(jx,jy)
            pha_re(jx,jy) = cos(work)
            pha_im(jx,jy) = sin(work)
          end do
        end do

        return
        end
**********************************************************************
        include 'hrsa:fft_jlp.for'


      double precision function slotted_disk_sum(x,y,z)
      implicit none

      double precision x,y,z

      double precision w(3), q, qv, b, c
      double precision r, hmax
      integer m, n, get_n_locations
      double precision slotted_disk

      n = get_n_locations()

      call get_td_sdisk_parms(r,hmax,b,c)

      q = 0
      do m = 1,n
         call get_td_gaussian_locations(m,w)
         qv = slotted_disk(x,y,z,w,r,hmax,m)
         q = q + qv
      enddo

      slotted_disk_sum = b + c*q
      end

      double precision function slotted_disk(x,y,z,w,r,hmax,
     &      which_disk)
      implicit none

      double precision x,y,z,w(3),r,hmax
      integer which_disk

      double precision th, lambda, thi, li, q
      double precision get_gc_distance, ri, pi

c     r = 0.5d0

      ri = get_gc_distance(x,y,z,w)

      call map2polar(w(1),w(2),w(3),lambda,th)
      call map2polar(x,y,z,li,thi)

c     # Default value
      q = 0

c     # Now check to if we are in a disk
      if (ri .lt. r) then
         if (abs(lambda - li) .gt. r/6.d0) then
            q = 1.d0
         else
            if (which_disk .eq. 1) then
               if (th - thi .gt. 5.d0*r/12) then
                  q = 1.d0
               endif
            else
               if (th - thi .lt. -5.d0*r/12) then
                  q = 1.d0
               endif
            endif
         endif
      endif

      slotted_disk = q

      end

c     # ----------------------------------------------------
c     # Set a,hmax parameters for slotted disk
c     # ----------------------------------------------------

      subroutine set_initial_sdisk_parms(r,hmax,b,c)
      implicit none

      double precision r,hmax, b,c

      double precision wc_init_com(3,100), r_init_com, hmax_init_com
      double precision b_init_com, c_init_com

      common /comsdinit1/ wc_init_com, r_init_com, hmax_init_com,
     &      b_init_com, c_init_com

      r_init_com = r
      hmax_init_com = hmax
      b_init_com = b
      c_init_com = c

      call set_td_sdisk_parms(r,hmax,b,c)

      end

      subroutine get_initial_sdisk_parms(r,hmax,b,c)
      implicit none

      double precision r,hmax, b,c

      double precision wc_init_com(3,100), r_init_com,
     &      hmax_init_com, b_init_com, c_init_com

      common /comsdinit1/ wc_init_com, r_init_com, hmax_init_com,
     &      b_init_com, c_init_com

      r = r_init_com
      hmax = hmax_init_com
      b = b_init_com
      c = c_init_com

      end

      subroutine set_td_sdisk_parms(r,hmax,b,c)
      implicit none

      double precision r,hmax,b,c

      double precision wc_td_com(3,100), r_td_com, hmax_td_com,
     &      b_td_com, c_td_com

      common /comsdinit1/ wc_td_com, r_td_com, hmax_td_com,
     &      b_td_com, c_td_com

      r_td_com = r
      hmax_td_com = hmax
      b_td_com = b
      c_td_com = c

      end

      subroutine get_td_sdisk_parms(r,hmax,b,c)
      implicit none

      double precision r,hmax, b, c

      double precision wc_td_com(3,100), r_td_com, hmax_td_com
      double precision b_td_com,c_td_com

      common /comsdinit1/ wc_td_com, r_td_com, hmax_td_com,
     &      b_td_com, c_td_com

      r = r_td_com
      hmax = hmax_td_com
      b = b_td_com
      c = c_td_com

      end


! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
MODULE Subdivisions

USE Precision_Model, ONLY: stnd
USE internal_types

Implicit NONE

PRIVATE

PUBLIC :: DIVIDE
PRIVATE :: DIVSMP

CONTAINS
      SUBROUTINE DIVIDE(DIMENS,NRVERT,MAXSUB,UNIFORM_SUBDIV,NUMFUN,VEROLD,   &
            INFOLD,RINFOL,Integrand,OUTSUB,NUM,VERNEW,INFNEW,RINFNE,IFAIL)
!***BEGIN PROLOGUE DIVIDE
!***DATE WRITTEN   900615  (YYMMDD)
!***REVISION DATE  910506  (YYMMDD)
!***REVISION DATE  970401  (YYMMDD) (subdivision modifications)
!***REVISION DATE  980331  (YYMMDD) (1D added)
!***REVISION DATE  980406  (YYMMDD) (2div for nCube added)
!***REVISION DATE  980408  (YYMMDD) (F conversion)
!***REVISION DATE  990525  (YYMMDD) (re-organising)
!***REVISION DATE  990602  (YYMMDD) (2/4-division for T2 activated)
!***REVISION DATE  990624  (YYMMDD) (2/4/8-division for C3 activated)
!***REVISION DATE  010919  (YYMMDD) (infold(4) code changed elsewhere)
!***REVISION DATE  020716  (YYMMDD) (replace MOD intrinsic by MODULO)
!***AUTHOR
!          Ronald Cools, Dept. of Computer Science,
!          Katholieke Universiteit Leuven, Celestijnenlaan 200A,
!          B-3001 Heverlee, Belgium
!          Email: Ronald.Cools@cs.kuleuven.ac.be
!
!          Alan Genz
!          Department of Mathematics
!          Washington State University
!          Pullman, WA 99164-3113, USA
!          Email: AlanGenz@wsu.edu

!
!***PURPOSE To divide a given region in OUTSUB subregions
!           with equal volume.
!
!***DESCRIPTION
!   Input parameters
!   ----------------
!   DIMENS Integer, dimension of the regions
!   NRVERT Integer, number of vertices that describe a region
!   MAXSUB Integer.
!          The given region is divided in at most MAXSUB subregions
!   UNIFORM_SUBDIV Logical.
!          If true, this routine does a 2**dim subdivision.
!          If false, this routine may decide to divide into less than
!          MAXSUB regions
!   NUMFUN Integer, number of components of the integral.
!   VEROLD Real array of dimension (dimens,nrvert)
!          Contains the vertices of the given region
!   INFOLD
!   RINFOL
!   Integrand
!          Externally declared function for computing all components
!          of the integrand at the given evaluation point.
!          It must have input parameter X:
!              X(1)      The x-coordinate of the evaluation point.
!              X(2)      The y-coordinate of the evaluation point.
!              ...
!              X(DIMENS) The z-coordinate of the evaluation point.
!         and NumFun, the number of components of the integrand.
!         It must be compatible with the following interface:
!           INTERFACE
!              FUNCTION Integrand(NumFun,X)
!                 USE Precision_Model
!                 INTEGER :: NumFun
!                 REAL(kind=stnd) :: X(:)
!                 REAL(kind=stnd) :: Integrand(NumFun)
!              END
!           END INTERFACE
!
!   Output parameters
!   -----------------
!   NUM    : Integer number of integrand values used to decide subdivision.
!   OUTSUB : Integer number of subregions the given region was divided into.
!   VERNEW : Real array of dimension (dimens,nrvert,MAXSUB)
!            Contains the vertices of the subregions.
!   INFNEW : Integer array of dimension (:,MAXSUM)
!            Contains additional information for each subregion.
!   RINFNE : Real array of dimension (:,MAXSUM)
!            Contains additional information for each subregion.
!   IFAIL  : integer to indicate success or failure
!            IFAIL = 0 on normal exit
!            IFAIL = 7 if the desired subdivision is not implemented
!                       for this type of region
!            IFAIL = 6 if no subdivsions are implemented for this type
!                       of region
!
!***ROUTINES CALLED  DIVSMP
!***END PROLOGUE DIVIDE
!
!  Global variables
      INTEGER, INTENT(IN)    :: DIMENS,NRVERT,MAXSUB,NUMFUN
      INTEGER, DIMENSION(:), INTENT(IN) :: INFOLD
      LOGICAL, INTENT(IN)    :: UNIFORM_SUBDIV
      REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VEROLD
      REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: RINFOL
      INTEGER, INTENT(OUT)   :: NUM,OUTSUB,IFAIL
      INTEGER, DIMENSION(:,:), INTENT(OUT) :: INFNEW
      REAL(kind=stnd), DIMENSION(:,:,:), INTENT(OUT):: VERNEW
      REAL(kind=stnd), DIMENSION(:,:), INTENT(OUT) :: RINFNE
      INTERFACE
         FUNCTION Integrand(NUMFUN,X) RESULT(Value)
            USE Precision_Model
            INTEGER, INTENT(IN) :: NUMFUN
            REAL(kind=stnd), DIMENSION(:), INTENT(IN) :: X
            REAL(kind=stnd), DIMENSION(NUMFUN) :: Value
         END FUNCTION Integrand
      END INTERFACE
!
!  Local variables
!
!   GEOMETRY : specifies the type of region
!
      INTEGER    :: I,J,GEOMETRY
      REAL(kind=stnd) :: VOLUME
      REAL(kind=stnd), DIMENSION(3) :: HALF_HEIGHT, HEIGHT
!
!***FIRST EXEUTABLE STATEMENT
      IF (MAXSUB == 1) THEN
            VERNEW(:,:,1) = VEROLD
            INFNEW(:,1) = INFOLD
            RINFNE(:,1) = RINFOL
            OUTSUB = 1
            NUM = 0
            IFAIL = 0
            RETURN
      END IF
!
      GEOMETRY = INFOLD(1)
      SELECT CASE (GEOMETRY)
      CASE (Simplex)
          IF (DIMENS == 1 ) THEN
              VERNEW(:,:,1) = VEROLD
              VERNEW(:,:,2) = VEROLD
              VERNEW(:,2,1) = (VEROLD(1,1)+VEROLD(1,2))/2
              VERNEW(:,1,2) = VERNEW(:,2,1)
              OUTSUB = 2
              NUM = 0
!
          ELSE IF ((DIMENS == 2) .AND. UNIFORM_SUBDIV ) THEN
              VERNEW(:,:,1) = VEROLD
              VERNEW(:,:,2) = VEROLD
              VERNEW(:,:,3) = VEROLD
              VERNEW(:,:,4) = VEROLD
              VERNEW(:,2,1) = ( VEROLD(:,1) + VEROLD(:,2) )/2
              VERNEW(:,3,1) = ( VEROLD(:,1) + VEROLD(:,3) )/2
              VERNEW(:,1,2) = VERNEW(:,2,1)
              VERNEW(:,3,2) = ( VEROLD(:,2) + VEROLD(:,3) )/2
              VERNEW(:,1,3) = VERNEW(:,3,1)
              VERNEW(:,2,3) = VERNEW(:,3,2)
              VERNEW(:,1,4) = VERNEW(:,3,2)
              VERNEW(:,2,4) = VERNEW(:,2,1)
              VERNEW(:,3,4) = VERNEW(:,3,1)
              OUTSUB = 4
              NUM = 0
!
          ELSE IF ((DIMENS == 3) .AND. UNIFORM_SUBDIV ) THEN
              VERNEW(:,1,1) = ( VEROLD(:,1) + VEROLD(:,4) )/2
              VERNEW(:,2,1) = ( VEROLD(:,1) + VEROLD(:,3) )/2
              VERNEW(:,3,1) = ( VEROLD(:,1) + VEROLD(:,2) )/2
              VERNEW(:,4,1) = VEROLD(:,1)
              VERNEW(:,:,2) = VERNEW(:,:,1)
              VERNEW(:,4,2) = ( VEROLD(:,2) + VEROLD(:,4) )/2
              VERNEW(:,:,3) = VERNEW(:,:,2)
              VERNEW(:,3,3) = ( VEROLD(:,3) + VEROLD(:,4) )/2
              VERNEW(:,:,4) = VERNEW(:,:,2)
              VERNEW(:,1,4) = ( VEROLD(:,2) + VEROLD(:,3) )/2
              VERNEW(:,:,5) = VERNEW(:,:,3)
              VERNEW(:,2,5) = VEROLD(:,4)
              VERNEW(:,:,6) = VERNEW(:,:,4)
              VERNEW(:,3,6) = VERNEW(:,3,3)
              VERNEW(:,:,7) = VERNEW(:,:,6)
              VERNEW(:,4,7) = VEROLD(:,3)
              VERNEW(:,:,8) = VERNEW(:,:,4)
              VERNEW(:,2,8) = VEROLD(:,2)
              OUTSUB = 8
              NUM = 0
!
          ELSE IF (.NOT. UNIFORM_SUBDIV ) THEN
              CALL DIVSMP( DIMENS, NUMFUN, MAXSUB, VEROLD, Integrand,  &
                           NUM, OUTSUB, VERNEW )
          ELSE
              IFAIL = 7
              RETURN
          END IF
!
      CASE (Hyperrectangle)
          SELECT CASE (DIMENS)
          CASE (1)
              VERNEW(:,:,1) = VEROLD
              VERNEW(:,:,2) = VEROLD
              VERNEW(:,2,1) = (VEROLD(1,1)+VEROLD(1,2))/2
              VERNEW(:,1,2) = VERNEW(:,2,1)
              OUTSUB = 2
              NUM = 0
          CASE (2)
            IF ((MAXSUB == 4) .OR. UNIFORM_SUBDIV) THEN
!
!          Divide a parallellogram in 4.
!
              VERNEW(:,1,1) = VEROLD(:,1)
              VERNEW(:,2,1) = ( VEROLD(:,1) + VEROLD(:,2) )/2
              VERNEW(:,3,1) = ( VEROLD(:,1) + VEROLD(:,3) )/2
              VERNEW(:,1,2) = ( VEROLD(:,2) + VEROLD(:,3) )/2
              VERNEW(:,2,2) = VEROLD(:,2) + ( VEROLD(:,3) - VEROLD(:,1) )/2
              VERNEW(:,3,2) = VEROLD(:,3) + ( VEROLD(:,2) - VEROLD(:,1) )/2
              VERNEW(:,1,3) = VERNEW(:,2,1)
              VERNEW(:,2,3) = VEROLD(:,2)
              VERNEW(:,3,3) = VERNEW(:,1,2)
              VERNEW(:,1,4) = VERNEW(:,3,1)
              VERNEW(:,2,4) = VERNEW(:,1,2)
              VERNEW(:,3,4) = VEROLD(:,3)
              OUTSUB = 4
              NUM = 0
          ELSE IF (MAXSUB == 2) THEN
!
!          Divide a parallellogram in 2.
!
              IF ( INFOLD(4) == 2 ) THEN
!                Cut orthogonal to the line through vertices 1-3
                 VERNEW(:,1,1) = VEROLD(:,1)
                 VERNEW(:,2,1) = VEROLD(:,2)
                 VERNEW(:,3,1) = ( VEROLD(:,1) + VEROLD(:,3) )/2
                 VERNEW(:,1,2) = VERNEW(:,3,1)
                 VERNEW(:,2,2) = VEROLD(:,2)+( VEROLD(:,3) - VEROLD(:,1) )/2
                 VERNEW(:,3,2) = VEROLD(:,3)
              ELSE
!                Cut orthogonal to the line through vertices 1-2
                 VERNEW(:,1,1) = VEROLD(:,1)
                 VERNEW(:,2,1) = ( VEROLD(:,1)+VEROLD(:,2) )/2
                 VERNEW(:,3,1) = VEROLD(:,3)
                 VERNEW(:,1,2) = VERNEW(:,2,1)
                 VERNEW(:,3,2) = VEROLD(:,2)
                 VERNEW(:,2,2) = VEROLD(:,3)+( VEROLD(:,2) - VEROLD(:,1) )/2
              END IF
              OUTSUB = 2
              NUM = 0
          ELSE
              IFAIL = 7
              RETURN
          END IF
!
          CASE (3)
          IF ((MAXSUB == 8) .OR. UNIFORM_SUBDIV) THEN
!
!          Divide a 3D-Cube in 8.
!
                 HALF_HEIGHT = (verold(1:3,4)-verold(1:3,1))/2
                 vernew(1:3,1,1) = verold(1:3,1)
                 vernew(1:3,2,1) = (verold(1:3,1)+verold(1:3,2))/2
                 vernew(1:3,3,1) = (verold(1:3,1)+verold(1:3,3))/2
                 vernew(1:3,4,1) = (verold(1:3,1)+verold(1:3,4))/2
                 vernew(1:3,1,2) = vernew(1:3,2,1)
                 vernew(1:3,2,2) = verold(1:3,2)
                 vernew(1:3,3,2) = (verold(1:3,2)+verold(1:3,3))/2
                 vernew(1:3,4,2) = (verold(1:3,2)+verold(1:3,4))/2
                 vernew(1:3,1,3) = vernew(1:3,3,1)
                 vernew(1:3,2,3) = vernew(1:3,3,2)
                 vernew(1:3,3,3) = verold(1:3,3)
                 vernew(1:3,4,3) = (verold(1:3,3)+verold(1:3,4))/2
                 vernew(1:3,1,4) = vernew(1:3,3,2)
                 vernew(1:3,2,4) = verold(1:3,2) +                      &
                                   (verold(1:3,3)-verold(1:3,1))/2
                 vernew(1:3,3,4) = verold(1:3,3) +                      &
                                   (verold(1:3,2)-verold(1:3,1))/2
                 vernew(1:3,4,4) = vernew(1:3,3,2) + HALF_HEIGHT
                 vernew(1:3,1,5) = vernew(1:3,4,1)
                 vernew(1:3,2,5) = vernew(1:3,4,2)
                 vernew(1:3,3,5) = vernew(1:3,4,3)
                 vernew(1:3,4,5) = verold(1:3,4)
                 vernew(1:3,1,6) = vernew(1:3,4,2)
                 vernew(1:3,2,6) = verold(1:3,2) +  HALF_HEIGHT
                 vernew(1:3,3,6) = vernew(1:3,4,4)
                 vernew(1:3,4,6) = vernew(1:3,4,2) + HALF_HEIGHT
                 vernew(1:3,1,7) = vernew(1:3,4,3)
                 vernew(1:3,2,7) = vernew(1:3,4,4)
                 vernew(1:3,3,7) = verold(1:3,3) + HALF_HEIGHT
                 vernew(1:3,4,7) = vernew(1:3,4,3) + HALF_HEIGHT
                 vernew(1:3,1,8) = vernew(1:3,4,4)
                 vernew(1:3,2,8) = vernew(1:3,2,4) + HALF_HEIGHT
                 vernew(1:3,3,8) = vernew(1:3,3,4) + HALF_HEIGHT
                 vernew(1:3,4,8) = vernew(1:3,4,4) + HALF_HEIGHT
              OUTSUB = 8
              NUM = 0

          ELSE IF (maxsub == 4) THEN
!
!          Divide a 3D-Cube in 4.
!
              IF (infold(4)/10 == -2) THEN
!     Cut orthogonal to the line through vertices 1-2 and vertices 1-3
                 HEIGHT = (verold(1:3,4) - verold(1:3,1))
                 vernew(1:3,1,1) = verold(1:3,1)
                 vernew(1:3,2,1) = (verold(1:3,1)+verold(1:3,2))/2
                 vernew(1:3,3,1) = (verold(1:3,1)+verold(1:3,3))/2
                 vernew(1:3,4,1) = verold(1:3,4)
                 vernew(1:3,1,2) = vernew(1:3,2,1)
                 vernew(1:3,2,2) = verold(1:3,2)
                 vernew(1:3,3,2) = (verold(1:3,2)+verold(1:3,3))/2
                 vernew(1:3,4,2) = vernew(1:3,2,1) + HEIGHT
                 vernew(1:3,1,3) = vernew(1:3,3,1)
                 vernew(1:3,2,3) = vernew(1:3,3,2)
                 vernew(1:3,3,3) = verold(1:3,3)
                 vernew(1:3,4,3) = vernew(1:3,3,1) + HEIGHT
                 vernew(1:3,1,4) = vernew(1:3,3,2)
                 vernew(1:3,2,4) = vernew(1:3,3,1) +                      &
                                   (verold(1:3,2) - verold(1:3,1))
                 vernew(1:3,3,4) = vernew(1:3,2,1) +                      &
                                   (verold(1:3,3) - verold(1:3,1))
                 vernew(1:3,4,4) = vernew(1:3,3,2) + HEIGHT
              ELSE IF (infold(4)/10 == -3) THEN
!     Cut orthogonal to the line through vertices 1-3 and vertices 1-4
                 HEIGHT = (verold(1:3,2) - verold(1:3,1))
                 HALF_HEIGHT = (verold(1:3,4) - verold(1:3,1))/2
                 vernew(1:3,1,1) = verold(1:3,1)
                 vernew(1:3,2,1) = verold(1:3,2)
                 vernew(1:3,3,1) = (verold(1:3,1)+ verold(1:3,3))/2
                 vernew(1:3,4,1) = verold(1:3,1) + HALF_HEIGHT
                 vernew(1:3,1,2) = vernew(1:3,3,1)
                 vernew(1:3,2,2) = vernew(1:3,3,1) + HEIGHT
                 vernew(1:3,3,2) = verold(1:3,3)
                 vernew(1:3,4,2) = vernew(1:3,3,1) + HALF_HEIGHT
                 vernew(1:3,1,3) = vernew(1:3,4,1)
                 vernew(1:3,2,3) = vernew(1:3,4,1) + HEIGHT
                 vernew(1:3,3,3) = vernew(1:3,4,2)
                 vernew(1:3,4,3) = verold(1:3,4)
                 vernew(1:3,1,4) = vernew(1:3,4,2)
                 vernew(1:3,2,4) = vernew(1:3,4,2) + HEIGHT
                 vernew(1:3,3,4) = verold(1:3,3) + HALF_HEIGHT
                 vernew(1:3,4,4) = vernew(1:3,4,2) + HALF_HEIGHT
              ELSE
!     Cut orthogonal to the line through vertices 1-2 and vertices 1-4
                 HALF_HEIGHT = (verold(1:3,4) - verold(1:3,1))/2
                 vernew(1:3,1,1) = verold(1:3,1)
                 vernew(1:3,2,1) = (verold(1:3,2) + verold(1:3,1))/2
                 vernew(1:3,3,1) = verold(1:3,3)
                 vernew(1:3,4,1) = verold(1:3,1) + HALF_HEIGHT
                 vernew(1:3,1,2) = vernew(1:3,2,1)
                 vernew(1:3,2,2) = verold(1:3,2)
                 vernew(1:3,3,2) = verold(1:3,3) +                       &
                                   (verold(1:3,2) - verold(1:3,1))/2
                 vernew(1:3,4,2) = vernew(1:3,2,1) + HALF_HEIGHT
                 vernew(1:3,1,3) = vernew(1:3,4,1)
                 vernew(1:3,2,3) = (verold(1:3,2) + verold(1:3,4))/2
                 vernew(1:3,3,3) = verold(1:3,3) + HALF_HEIGHT
                 vernew(1:3,4,3) = verold(1:3,4)
                 vernew(1:3,1,4) = vernew(1:3,4,2)
                 vernew(1:3,2,4) = verold(1:3,2) + HALF_HEIGHT
                 vernew(1:3,3,4) = vernew(1:3,3,2) + HALF_HEIGHT
                 vernew(1:3,4,4) = vernew(1:3,4,2) + HALF_HEIGHT

              END IF
              OUTSUB = 4
              NUM = 0

          ELSE IF (maxsub == 2) THEN
!
!          Divide a 3D-Cube in 2.
!
              IF (modulo(abs(infold(4)),10) == 2) THEN
!     Cut orthogonal to the line through vertices 1-3
                 vernew(1:3,1,1) = verold(1:3,1)
                 vernew(1:3,2,1) = verold(1:3,2)
                 vernew(1:3,3,1) = (verold(1:3,1)+verold(1:3,3))/2
                 vernew(1:3,4,1) = verold(1:3,4)
                 vernew(1:3,1,2) = vernew(1:3,3,1)
                 vernew(1:3,2,2) = vernew(1:3,3,1) +                     &
                                   (verold(1:3,2) - verold(1:3,1))
                 vernew(1:3,3,2) = verold(1:3,3)
                 vernew(1:3,4,2) = vernew(1:3,3,1) +                     &
                                   (verold(1:3,4) - verold(1:3,1))
              ELSE IF (modulo(abs(infold(4)),10) == 3) THEN
!     Cut orthogonal to the line through vertices 1-4
                 vernew(1:3,1,1) = verold(1:3,1)
                 vernew(1:3,2,1) = verold(1:3,2)
                 vernew(1:3,3,1) = verold(1:3,3)
                 vernew(1:3,4,1) = (verold(1:3,1)+verold(1:3,4))/2
                 vernew(1:3,1,2) = vernew(1:3,4,1)
                 vernew(1:3,2,2) = vernew(1:3,4,1) +                     &
                                   (verold(1:3,2) - verold(1:3,1))
                 vernew(1:3,3,2) = vernew(1:3,4,1) +                     &
                                   (verold(1:3,3) - verold(1:3,1))
                 vernew(1:3,4,2) = verold(1:3,4)
              ELSE
!     Cut orthogonal to the line through vertices 1-2
                 vernew(1:3,1,1) = verold(1:3,1)
                 vernew(1:3,2,1) = (verold(1:3,1)+verold(1:3,2))/2
                 vernew(1:3,3,1) = verold(1:3,3)
                 vernew(1:3,4,1) = verold(1:3,4)
                 vernew(1:3,1,2) = vernew(1:3,2,1)
                 vernew(1:3,2,2) = verold(1:3,2)
                 vernew(1:3,3,2) = vernew(1:3,2,1) +                     &
                                   (verold(1:3,3) - verold(1:3,1))
                 vernew(1:3,4,2) = vernew(1:3,2,1) +                     &
                                   (verold(1:3,4) - verold(1:3,1))
              END IF
              OUTSUB = 2
              NUM = 0
          ELSE
              IFAIL = 7
              RETURN
          END IF
          CASE DEFAULT
!
!          IF DIMENS > 3, then divide in 2 according to infold(4).
!
              J = INFOLD(4)
              IF ( J == 0 ) THEN
                                   J = 1
              END IF
              DO I = 1,NRVERT
                 IF ( J == I-1 ) THEN
                    VERNEW(:,I,1) = (VEROLD(:,1) + VEROLD(:,I))/2
                 ELSE
                    VERNEW(:,I,1) = VEROLD(:,I)
                 END IF
              END DO
              HALF_HEIGHT(1) = (VEROLD(J,J+1) - VEROLD(J,1))/2
              DO I = 1,NRVERT
                 IF ( J == I-1 ) THEN
                    VERNEW(:,I,2) = VEROLD(:,I)
                 ELSE
                    VERNEW(:,I,2) = VERNEW(:,I,1)
                    VERNEW(J,I,2) = VERNEW(J,I,2) + HALF_HEIGHT(1)
                 END IF
              END DO
              OUTSUB = 2
              NUM = 0
          END SELECT
      CASE DEFAULT
          IFAIL = 6
          RETURN
      END SELECT
      VOLUME = RINFOL(1)/OUTSUB
!
!  Update/copy information record
!
      INFNEW(1,1:OUTSUB) = GEOMETRY
      INFNEW(2,1:OUTSUB) = INFOLD(2) + 1
      INFNEW(3,1:OUTSUB) = INFOLD(3)
      INFNEW(4:5,1:OUTSUB) = 0
      RINFNE(1,1:OUTSUB) = VOLUME
      DO I = 1,OUTSUB
          INFNEW(6:,I) = INFOLD(6:)
          RINFNE(2:,I) = RINFOL(2:)
      END DO
      IFAIL = 0
      RETURN
      END SUBROUTINE DIVIDE

      SUBROUTINE DIVSMP( DIMENS, NF, MAXSUB, VEROLD, Integrand,       &
                         FUNCLS, OUTSUB, VERNEW )
!***BEGIN PROLOGUE DIVSMP
!***PURPOSE  To compute new subregions
!***AUTHOR
!
!          Alan Genz
!          Department of Mathematics
!          Washington State University
!          Pullman, WA 99164-3113, USA
!          AlanGenz@wsu.edu
!
!          Ronald Cools, Dept. of Computer Science,
!          Katholieke Universiteit Leuven, Celestijnenlaan 200A,
!          B-3001 Heverlee, Belgium
!          Email: Ronald.Cools@cs.kuleuven.ac.be
!
!
!***LAST MODIFICATION 97-03
!***DESCRIPTION DIVSMP computes fourth differences along each edge
!            direction. It uses these differences to determine a
!            subdivision of the orginal subregion into two new subregions.
!
!   ON ENTRY
!
!   DIMENS  Integer number of variables.
!   NF      Integer number of components for the vector integrand.
!   MAXSUB  Integer.
!           The given region is divided into at most MAXSUB subregions.
!   VEROLD  Real array of dimension (N,0:N), orginal subregion vertices.
! Integrand Real vector function of length NF for computing components of
!            the integrand at Z.
!            It must have parameters ( NF, Z ). See interface below.
!            Input parameters:
!              Z      Real array of length DIMENS, the evaluation point.
!              NF     Integer number of components of Integrand.
!
!   ON RETURN
!
!   OUTSUB Integer number of subregions the given region was divided into.
!   FUNCLS Integer number of Integrand calls used by DIVSMP.
!   VERNEW Real array of dimension (N,0:N,MAXSUB).
!          The vertices of the MAXSUB new subegions.
!
!***ROUTINES CALLED: Integrand
!***END PROLOGUE DIVSMP
      INTERFACE
         FUNCTION Integrand( NF, Z ) RESULT(Value)
             USE Precision_Model
         INTEGER, INTENT(IN) :: NF
         REAL(kind=STND), DIMENSION(:), INTENT(IN) :: Z
         REAL(kind=STND), DIMENSION(NF) :: Value
         END FUNCTION Integrand
      END INTERFACE
      INTEGER, INTENT(IN) :: DIMENS, NF, MAXSUB
      INTEGER, INTENT(OUT) :: OUTSUB, FUNCLS
      REAL(kind=STND), INTENT(IN), DIMENSION(1:,0:) :: VEROLD
      REAL(kind=STND), INTENT(OUT), DIMENSION(1:,0:,1:) :: VERNEW
!
!   Local Arrays
!   X      Real work array of length DIMENS.
!   H      Real work array of length DIMENS.
!   CENTER Real work array of length DIMENS.
!   WORK   Real work array of dimension (NF,5).
!   FRTHDF Real work array of dimension (0:DIMENS,0:DIMENS).
!   EWIDTH Real work array of dimension (0:DIMENS,0:DIMENS).
!
      REAL(kind=STND), DIMENSION(5), PARAMETER :: DIFCON = (/ 1, -4, 6, -4, 1 /)
      REAL(kind=STND), DIMENSION(DIMENS) :: X, H, CENTER
      REAL(kind=STND), DIMENSION(NF,5) :: WORK
      REAL(kind=STND), DIMENSION(0:DIMENS,0:DIMENS) :: FRTHDF, EWIDTH
      REAL(kind=STND) :: DIFMID, DIFMAX, DIFMIN
      INTEGER :: J, K, L, IMX, JMX, KMX, LMX, LTMP
      INTEGER, DIMENSION(2) :: INDX
!
!***FIRST PROCESSING STATEMENT DIVSMP
!
!
!     Compute the differences.
!
      CENTER = MATMUL( VEROLD, SPREAD( 1, 1, DIMENS+1 ) )/(DIMENS+1)
      WORK(:,3) = Integrand( NF, CENTER )
      FRTHDF = 0
      EWIDTH = 0
      DO L = 0, DIMENS-1
         DO K = L+1, DIMENS
            H = VEROLD(:,K) - VEROLD(:,L)
            EWIDTH(L,K) = SUM( ABS( H ) )

            H = 2*H/( 5*( DIMENS + 1 ) )
            X = CENTER - 3*H
            DO J = 1, 5
               X = X + H
               IF ( J  /=  3 ) THEN
                                     WORK(:,J) = Integrand( NF, X )
               END IF
            END DO
            DIFMID = SUM( ABS( MATMUL( WORK(:,:), DIFCON ) ) )
!
!           Ignore differences below roundoff
!
            IF ( SUM( ABS(WORK(:,3)) ) + DIFMID/8 > SUM( ABS(WORK(:,3)) ) ) THEN
                 FRTHDF(L,K) = DIFMID
            END IF
         END DO
      END DO
      FRTHDF = FRTHDF*EWIDTH
      IF ( MAXVAL( FRTHDF ) == 0 ) THEN
                                         FRTHDF = EWIDTH
      END IF
      INDX(1:2) = MAXLOC( FRTHDF ) - 1
      LMX = INDX(1)
      KMX = INDX(2)
      VERNEW(:,:,1) = VEROLD
      VERNEW(:,:,2) = VEROLD
!
      IF ((DIMENS == 2) .AND. (MAXSUB >=4)) THEN
         DIFMAX = FRTHDF(LMX,KMX)
         DIFMIN = MIN(frthdf(0,1),frthdf(0,2),frthdf(1,2))
         IF ( (DIFMAX > 0.001*ewidth(lmx,kmx)) .AND. ( DIFMIN <= 0.45_stnd*DIFMAX )) THEN  ! 2-division
            VERNEW(:,LMX,2) = ( VEROLD(:,KMX) + VEROLD(:,LMX) )/2
            VERNEW(:,KMX,1) =   VERNEW(:,LMX,2)
            OUTSUB = 2
         ELSE ! 4-division
            ! VERNEW(:,:,1) = VEROLD ; VERNEW(:,:,2) = VEROLD
            VERNEW(:,:,3) = VEROLD
            VERNEW(:,:,4) = VEROLD
            VERNEW(:,1,1) = ( VEROLD(:,0) + VEROLD(:,1) )/2
            VERNEW(:,2,1) = ( VEROLD(:,0) + VEROLD(:,2) )/2
            VERNEW(:,0,2) = VERNEW(:,1,1)
            VERNEW(:,2,2) = ( VEROLD(:,1) + VEROLD(:,2) )/2
            VERNEW(:,0,3) = VERNEW(:,2,1)
            VERNEW(:,1,3) = VERNEW(:,2,2)
            VERNEW(:,0,4) = VERNEW(:,2,2)
            VERNEW(:,1,4) = VERNEW(:,1,1)
            VERNEW(:,2,4) = VERNEW(:,2,1)
            OUTSUB = 4
         END IF
      ELSE IF ( MAXSUB == 2 ) THEN
!
!        Compute two new subregions.
!
         VERNEW(:,LMX,2) = ( VEROLD(:,KMX) + VEROLD(:,LMX) )/2
         VERNEW(:,KMX,1) =   VERNEW(:,LMX,2)
         OUTSUB = 2
      ELSE
         DIFMAX = FRTHDF(LMX,KMX)
!
         FRTHDF(LMX,KMX) = 0
         INDX(1:2) = MAXLOC( FRTHDF ) - 1
         JMX = INDX(1)
         IMX = INDX(2)
!
         FRTHDF(JMX,IMX) = 0
         INDX(1:2) = MAXLOC( FRTHDF ) - 1
         JMX = INDX(1)
         IMX = INDX(2)
!
         DIFMID = FRTHDF(JMX,IMX)
         IF ( DIFMAX > 2*DIFMID .OR. MAXSUB == 3 ) THEN
! Tobedone            ^^ tune this parameter                RC
!
!           Compute three new subregions.
!
            VERNEW(:,:,3) = VEROLD
            WHERE ( FRTHDF == 0 )
                  FRTHDF = TRANSPOSE( FRTHDF )
            END WHERE
            INDX(1:1) = MAXLOC( FRTHDF(LMX,:) + FRTHDF(KMX,:) ) - 1
            JMX = INDX(1)
            IF ( FRTHDF(LMX,JMX) > FRTHDF(KMX,JMX) ) THEN
               LTMP = KMX
               KMX = LMX
               LMX = LTMP
            END IF
            DIFMID = FRTHDF(KMX,JMX)
            VERNEW(:,KMX,1) = ( 2*VEROLD(:,LMX) + VEROLD(:,KMX) )/3
            VERNEW(:,LMX,2) =     VERNEW(:,KMX,1)
            VERNEW(:,KMX,2) =     VEROLD(:,JMX)
            IF ( DIFMID > DIFMAX/8 ) THEN
! Tobedone                       ^^ tune this parameter              RC
               VERNEW(:,JMX,2) = ( VEROLD(:,KMX) + VEROLD(:,JMX) )/2
               VERNEW(:,JMX,3) =   VERNEW(:,LMX,2)
            ELSE
               VERNEW(:,JMX,2) = ( VEROLD(:,LMX) + 2*VEROLD(:,KMX) )/3
               VERNEW(:,JMX,3) =   VEROLD(:,JMX)
            END IF
            VERNEW(:,LMX,3) = VERNEW(:,JMX,2)
            OUTSUB = 3
         ELSE
!
!           Compute four new subregions.
!
            VERNEW(:,LMX,2) = ( VEROLD(:,KMX) + VEROLD(:,LMX) )/2
            VERNEW(:,KMX,1) =   VERNEW(:,LMX,2)
            VERNEW(:,:,3) =     VERNEW(:,:,1)
            VERNEW(:,JMX,3) = ( VERNEW(:,IMX,1) + VERNEW(:,JMX,1) )/2
            VERNEW(:,IMX,1) =   VERNEW(:,JMX,3)
            VERNEW(:,:,4) =     VERNEW(:,:,2)
            VERNEW(:,JMX,4) = ( VERNEW(:,IMX,2) + VERNEW(:,JMX,2) )/2
            VERNEW(:,IMX,2) =   VERNEW(:,JMX,4)
            OUTSUB = 4
         END IF
      END IF
      FUNCLS = 1 + 2*DIMENS*(DIMENS+1)
      RETURN
      END SUBROUTINE DIVSMP
END MODULE Subdivisions


!------------------------------------------------------------------------------
! USTC-AEMOL, geostrophic_wind_4_teaching
!------------------------------------------------------------------------------
!
!> @author
!> Fanghe Zhao}
!> zfh1997 at mail.ustc.edu.cn}
!
! DESCRIPTION:
!>  A simple model just for solving geostrophic_wind
!
! LICENSE: MIT
!
! REVISION HISTORY:
! 02 10 2018 - Initial Version
!------------------------------------------------------------------------------
module utils
    implicit none

    contains

    function distance(lon1, lat1, lon2, lat2)
    !
    ! This function is for compute distance between two points
    !
    ! Author : Fanghe Zhao
        implicit none

        real, parameter :: R_e = 6371
        real :: lon1, lat1, lon2, lat2
        real :: distance
        real :: dlon, dlat
        real :: a, b
        dlon = lon2 - lon1
        dlat = lat2 - lat1
        a = SIN(dlat / 2)**2 + COS(lat1) * COS(lat2) * SIN(dlon / 2)**2
        b = 2 * ATAN2(SQRT(a), SQRT(1 - a))
        distance = R_e * b * 1000

        return
    end function distance

    subroutine message_display(str_in)
    !
    ! This function is for print message in fix format
    !
    ! Author : Fanghe Zhao
        implicit none
        character (len = 20), intent(in) :: str_in
        write(6, *) "==========================="
        write(6, *) str_in
        write(6, *) "==========================="
    end subroutine message_display

end module

program geostrophic_wind
    !
    ! This Program is for compute geostrophic wind use ECMWF data
    !
    ! Author : Fanghe Zhao
    use netcdf
    use utils
    implicit none
    ! Var Defination
    integer, parameter :: nx = 33,ny = 23
    real, parameter :: g = 9.8
    real, parameter :: omega = 7.292e-5
    character (len = *), parameter :: IN_FILE_NAME = "hgt_location_selected.nc"
    character (len = *), parameter :: OUT_FILE_NAME = "geo_wind.nc"
    integer(kind=1) :: ierr
    integer :: i, j
    integer :: ncid, hgtid, lonid, latid, uid, vid
    integer :: y_dimid, x_dimid
    real :: dx, dy ,f
    integer,dimension(2) :: dimids
    real, dimension(ny, nx) :: hgt = 0, u = 0, v = 0
    real, dimension(ny) :: lat
    real, dimension(nx) :: lon

    include 'netcdf.inc'

    ! Read input netcdf file
    call message_display("Read Input File")
    ncid = 100
    ierr = nf90_open(path = IN_FILE_NAME, mode = NF90_NOWRITE ,ncid = ncid)
    ierr = nf_inq_varid(ncid, 'hgt', hgtid)
    ierr = nf_inq_varid(ncid, 'lon', lonid)
    ierr = nf_inq_varid(ncid, 'lat', latid)

    ierr = nf_get_var_real(ncid, lonid, lon)
    ierr = nf_get_var_real(ncid, latid, lat)
    ierr = nf_get_var_real(ncid, hgtid, hgt)

    ierr = nf_close(ncid)
    call message_display("Read Input File End")

    ! Compute Geo-wind
    call message_display("Compute Geo-wind")
    do i = 1, nx
        do j = 1, ny
            f = (2 * omega * SIN(lat(j)))
            if (i .eq. 0 .and. j .eq. 0) then
                dx = distance(lon(i), lat(j), lon(i + 1), lat(j))
                dy = distance(lon(i), lat(j), lon(i), lat(j + 1))
                u(j, i) = -1 * (g / f) * (hgt(j + 1, i) - hgt(j, i)) / (dy)
                v(j, i) = (g / f) * (hgt(j, i + 1) - hgt(j, i)) / (dx)
            else if (i .eq. nx .and. j .eq. ny) then
                dx = distance(lon(i - 1), lat(j), lon(i), lat(j))
                dy = distance(lon(i), lat(j - 1), lon(i), lat(j))
                u(j, i) = -1 * (g / f) * (hgt(j, i) - hgt(j - 1, i)) / (dy)
                v(j, i) = (g / f) * (hgt(j, i) - hgt(j, i - 1)) / (dx)
            else if (i .eq. nx .and. j .eq. 0) then
                dx = distance(lon(i - 1), lat(j), lon(i), lat(j))
                dy = distance(lon(i), lat(j), lon(i), lat(j + 1))
                u(j, i) = -1 * (g / f) * (hgt(j + 1, i) - hgt(j, i)) / (dy)
                v(j, i) = (g / f) * (hgt(j, i) - hgt(j, i - 1)) / (dx)
            else if (i .eq. 0 .and. j .eq. ny) then
                dx = distance(lon(i), lat(j), lon(i + 1), lat(j))
                dy = distance(lon(i), lat(j - 1), lon(i), lat(j))
                u(j, i) = -1 * (g / f) * (hgt(j, i) - hgt(j - 1, i)) / (dy)
                v(j, i) = (g / f) * (hgt(j, i + 1) - hgt(j, i)) / (dx)
            else
                dx = distance(lon(i - 1), lat(j), lon(i + 1), lat(j))
                dy = distance(lon(i), lat(j - 1), lon(i), lat(j + 1))
                u(j, i) = -1 * (g / f) * (hgt(j + 1, i) - hgt(j - 1, i)) / (dy)
                v(j, i) = (g / f) * (hgt(j, i + 1) - hgt(j, i - 1)) / (dx)
            end if
        end do
    end do
    call message_display("Compute Geo-wind End")

    ! Output File
    call message_display("Write Output File")
    ierr = nf90_create(OUT_FILE_NAME, NF90_CLOBBER, ncid)
    ierr = nf90_def_dim(ncid, "lon", nx, x_dimid)
    ierr = nf90_def_dim(ncid, "lat", ny, y_dimid)
    dimids =  (/ y_dimid, x_dimid /)
    ierr = nf90_def_var(ncid, "u", NF90_FLOAT, dimids, uid)
    ierr = nf90_def_var(ncid, "v", NF90_FLOAT, dimids, vid)
    ierr = nf90_def_var(ncid, "lon", NF90_INT, x_dimid, lonid)
    ierr = nf90_def_var(ncid, "lat", NF90_INT, y_dimid, latid)
    ierr = nf90_enddef(ncid)
    ierr = nf90_put_var(ncid, uid, u)
    ierr = nf90_put_var(ncid, vid, v)
    ierr = nf90_put_var(ncid, lonid, lon)
    ierr = nf90_put_var(ncid, latid, lat)
    ierr = nf90_close(ncid)
    call message_display("Write Output File End")

end program geostrophic_wind